[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『データ入力ファイル→管理ファイルへ？（追加質問）』（syus）
以前はスムーズかつ明確なご回答を頂き、 大変役立ちました。また質問させていただきます。
そもそもエクセルでやるものなのか？ という疑問もあるかと思うのですが、宜しくお願い致します。
まず、データ登録シートにデータを入力します。 （このファイルをデータ.xlsとします。）
このファイルはエクセルではあるのですが、 規則正しく並んだセルではありません。 銀行の口座登録用紙のような感じになっています。 入力項目が氏名、年齢・・・といった感じでたくさんあるものだとイメージしていただければわかりやすいかと思います。
このファイルに必要事項を書き込んだ後、 他のデータ管理用ファイルに必要部分だけ抜き出して表示させたいのです。
データ.xlsに入力する項目が氏名、年齢、職業、電話番号、メールアドレスだったとします。 入力した5項目のうち、氏名、年齢だけを別の管理ファイルに抽出して、まとめたい。 といった感じで考えております。 管理用ファイルのほうは、 A行に氏名、B行に年齢というように、セルはそのまま使うこととします。 そして、管理用ファイルの氏名をクリックするとデータ.xlsにジャンプするようにしたいと考えております。
以上になるのですが、若干補足を。 ・データ.xlsは毎回新しいファイルを作成しようと考えている。 →Aさん.xls、Bさん.xlsという風に増えていく予定です。 ・Excel2002、OSはXPです。
長文失礼いたしました。 読んでいただけた方、是非ご教授頂ければと思います。 構成自体の質問のような気がして若干心苦しいのですが、何卒よろしくお願い致します。
1) > ・データ.xlsは毎回新しいファイルを作成しようと考えている。 > →Aさん.xls、Bさん.xlsという風に増えていく予定です。
各.xlsファイルは1レコードのみ保存されるのですか？ シートは1枚だけですか？
2) > 管理用ファイルの氏名をクリックするとデータ.xlsにジャンプするようにしたいと考えております。
どのような理由でジャンプさせる必要があるのですか？
(seiya)
1)はシートは1枚で考えております。 あるいは、ファイル数を減らすために数人分ずつまとめて保存したほうが管理データに飛ばすことを考えるとよいのでしょうか？逆にアドバイス頂きたいです。
2）管理用ファイルで閲覧中に、細かい情報を確認したいときのためです。 今後、ファイル数が増えていくに従って、いちいち1つ1つの個人データを探して開かなくてもすむようにです。
答えられていますでしょうか？？よろしくお願い致します。
(syus)
各ファイルの構成、使用目的が不明でしたので質問しました。
各ファイルは誰がどのように入力するのですか？
ファイルを際限なく作成することはお勧めしません。 使用目的/状況を詳しく説明された方が、よい回答/アドバイスができると思います。 (seiya)
ご指摘ありがとうございます。 各ファイルの使用用途、状況を説明致します。
データファイルの方は、個人プロフィールです。 顔写真が入っているプロフィールです。面接後に面接担当者が入力するケースが多いです。 現状では、写真が入っていて少々重くなりがちなので、一人一人ファイルを分けています。 芸能事務所などのHPにあるタレントプロフィールだと思ってもらえればいいかなと思います。
管理ファイルの方は、言い換えれば名簿です。 使用目的としては、住所や最寄駅確認などになります。
管理ファイルのほうからのリンクに関してもう一度説明させていただきますと、 管理ファイルにて最寄駅などから、条件にマッチングする人をピックアップし、 ピックアップ後に、詳細を見ながら確認、といったイメージです。
いかがでしょうか？
えーーと、
面接時には既に写真が貼り付けてあり、面接官が各項目を埋めていく
という具合ですか？
そのファイルは誰が作成しているのですか？ 各応募者が独自に作成したものですか？ それとも、あらかじめ雛形を用意してあるのですか？
方法としては、面接が終了した時点で管理ファイルに転送してしまえばよいような... (seiya)
>面接時には既に写真が貼り付けてあり、面接官が各項目を埋めていく >という具合ですか？
一度手書きで紙に落としたものを後でデータ入力と言った具合です。 なので、写真は面接時に面接官が撮ったものをPCに写して、 データに貼り付けて・・・といった手順です。
>そのファイルは誰が作成しているのですか？
作成者はデータを入力する人間なので、 面接担当者それぞれが大半をしめておりますが、 他の手すきの人間が行う場合もあります。
>各応募者が独自に作成したものですか？ >それとも、あらかじめ雛形を用意してあるのですか？
雛形をアウトしたものに面接官が記入し、データ入力です。
管理ファイル自体にも打ち込むしかないんでしょうか？？ 実は前任からの引継ぎなのですが、 一人一人で作ってあるファイルが既に大量にありまして・・・。 それをどうにか活用できないかと思い、質問させて頂いた次第であります。
> 一度手書きで紙に落としたものを後でデータ入力と言った具合です。 > なので、写真は面接時に面接官が撮ったものをPCに写して、 > データに貼り付けて・・・といった手順です
これをそのまま管理ファイルに入力した方がすっきりすると思いますが？ それはできませんか？ (seiya)
seiyaさん
もちろん可能です。 ただ、プロフィール用の詳細データ（面接時に記入するもの）は、 必ず必要なので、結局二度手間になってしまうわけです。 管理用データは出来るだけコンパクトにまとめたいため、 プロフィールのような詳細データはいらないわけです。 検索もスムーズに出来ますし。
なので、プロフィール用に入力するだけで、管理用にも入力されたらいいなぁ・・・ といったところなのですが。。。
前述させて頂きましたが、今までのデータもあるので、 出来れば過去のデータも何らかの方法を用いて管理用に飛ばせたら、と思っております。
まだ全体の流れが見えてきませんね--...
> 雛形をアウトしたものに面接官が記入し、データ入力です。
^^^^^^^^^^^^^^^^^^^^
この元のファイルは誰が作成するのですか？
> ただ、プロフィール用の詳細データ（面接時に記入するもの）は、 > 必ず必要なので、結局二度手間になってしまうわけです。
上記と、 「一度手書きで紙に落としたものを後でデータ入力と言った具合です。」 はどのような関連がありますか？ (seiya)
seiyaさん
度々申し訳ないです汗。。。
雛形はもともとあって、それを毎回プリントアウトして、 記入用紙として使っているということです。 なので、雛形は既に作成済みです。
プロフィール用詳細データは手書きのものを入力するだけの作業です。
銀行の口座申込用紙を例にすると・・・
口座用紙（雛形）に必要事項を手書きで記入。 (銀行では足りなくなったら用紙は補充されていますよね？面接シートも同様です） ①記入された用紙の内容をそのまま個人情報（プロフィール）として入力。 ②詳細情報から必要部分だけ別の管理ファイルに飛ばしたい。
といった内容です。
なので、
>> ただ、プロフィール用の詳細データ（面接時に記入するもの）は、 >> 必ず必要なので、結局二度手間になってしまうわけです。
>上記と、 「一度手書きで紙に落としたものを後でデータ入力と言った具合です。」 >はどのような関連がありますか？
プロフィール用詳細データというのは、プリントアウトされた面接シートに書かれた個人情報です。 これが“一度手書きで紙に落としたもの”に該当します。 これをそのまま雛形と同様の書式のファイルに打ち込むわけです。 二度手間になるというのは、個人情報全体の中で、 管理用ファイルに必要なのは一部なので、抽出でなんとかなるんじゃないか、と思ったわけです。
>これをそのまま管理ファイルに入力した方がすっきりすると思いますが？ >それはできませんか？
この部分を管理ファイルにもう一度打ち込めば？とおっしゃったように捕らえたんですが、 取り違えでしたか？？
syusさんと衝突しちゃいましたが 取り敢えず載せておきます。
１．面接を行う前に記入シートを出力（雛形をアウト。何も記入されていない用紙） ２．面接時記入。写真も撮る。（面接時に記入するもの。手書きで紙に） ３．２の用紙を見ながら、プロフィール用の詳細データを入力（後でデータ入力） ＆写真も貼り付ける （レイアウトは、リスト形式ではなく 一品一葉形式。）
管理用ファイルには 詳細データから 写真他不要データを除いたデータを リスト形式で参照したい
と言う事かと思います。
問題は 既に３のブックが大量に有る 写真の管理 意識改革 と言う事になりそうに思いますが・・・。
(HANA)
そうなると、逆にした方がよいような気がします。
1) 紙データから管理ファイルに入力
2) 1) から面接時に必要なデータを「雛形ファイル」に転送
3) 2)の入力が終了した時点で、必要データを管理ファイルに転送
ネットワーク環境で使用ですか？ (seiya)
HANAさん
わかりやすい説明をありがとうございます。 意識改革・・・というのは二度手間くらい惜しむなってことでしょうか汗。。
seiyaさん
ネットワーク環境ではないです。
>2) 1) から面接時に必要なデータを「雛形ファイル」に転送 逆に面接時には、必要事項が何も記入されていないものなので、雛形のみの状態です。
HANAさんがおっしゃっている流れがまさに的を得ていて非常にわかりやすいと思います。 説明が稚拙で申し訳ありません。。
(syus)
＞二度手間くらい惜しむなってことでしょうか いやいや、手間はとりたくないですからね。 せっかくエクセル使ってるんですから 楽がしたい！！
私がするなら、 入力は一品一葉で入力し、リスト形式で保存 詳細データを確認したい場合は リストから該当データを抜き出し 一品一葉形式で表示。 管理用ファイルにも、このリストから必要部分だけを抜き出して表示 にしたい所ですが、写真が使用されている事と 既に大量に有るファイルが問題になってきますし 同時入力なんて事を考えるとこれも難しそうです。
たぶん、seiyaさんが いい方法を提案して下さいますよ。（ムセキニン）
seiyaさんが言って居られるのは（タブン） 管理用ファイルに必要なデータは、先にそちらに入力して そこから詳細データファイルを作成 （この時、管理用ファイルに入力したダブっている項目のみ入力された状態） その後、詳細データにのみ必要なデータ（空いている項目）＆写真を入力し 保存。 と言う流れかと思います。
(HANA)
HANAさん
なるほど！！ seiyaさん、理解力に乏しく、ご迷惑おかけしております。。。 それならば可能です。
過去データに関しては・・・ どうにかします。時間を割いて（笑）
あ、HANAさん。。 意識改革が未だに引っかかっている私なんですが・・・ ファイルをボコボコ作っていくところってことですかね？？
(syus)
あ・・・でも上の方で seiyaさんが ＞方法としては、面接が終了した時点で管理ファイルに転送してしまえばよいような... と書いて居られるので、詳細ファイルと管理ファイルが同時に出来るなら 「その都度 転送」でも良いように思います。
この管理ファイルって誰が作るんですか？ 詳細ファイルを色々な人が好きな時間帯で作ると 管理ファイルを更新するのに衝突（他の人が編集中） に成る可能性が有ると思いますが。。。
＞意識改革 ってのは、たぶんそこです。 一品一葉に慣れている人は リスト形式でデータを管理することに 抵抗を感じる方が多いように思いますので。
(HANA)
HANAさん、どうもです。
syusさん HANAさんが私の言わんとしたことを、的確に表現していただけましたので（どうもはしょってしまって） ...
面接時に入力するファイルと、管理ファイルは別にしないといけませんか？ (同時に複数の面接官が使用することは？） (seiya)
HANAさん
都度転送だと、コピペでしょうか？？ それとも関数で何か有用なものがありますか？
管理ファイル自体の更新者は私一人です。 なので、衝突の心配はないと思います。 ご心配頂きましてありがとうございます☆
>＞意識改革 >ってのは、たぶんそこです。 >一品一葉に慣れている人は リスト形式でデータを管理することに >抵抗を感じる方が多いように思いますので。
前任者がそのやり方をとっていただけなので、大丈夫です！
seiyaさん
面接時に書かれた紙が溜まっている状態から入力していくので、 同時に複数の人間が使用することはありません。 入力するファイルと、管理ファイルが一緒な分にはもちろん大歓迎なのですが、 何しろ前述のとおり、写真データ搭載なもので、 1つのファイルにまとめると容量にかなりの不安があるんです。。。
(syus)
案としては...
1) 管理ファイルのあるシート（Sheet1としましょう) にすべてのデータを蓄積 2) 面接データはSheet1の名前をダブルクリックで面接シート(Sheet2としましょう）に転送 3) 面接官の入力終了でSheet1をアップデート 4) 画像は別ファイルで保存し、必要に応じて表示
でいかがですか？ (seiya)
＞都度転送だと、コピペでしょうか？？ ＞それとも関数で何か有用なものがありますか？ えっと・・・入力を簡単にするなら マクロになると思います。
それにしても、話が分からなくなってきたのですが 詳細データの入力もsyusさんが行われるのですか？
でしたら話はそう難しくないと思いますが。。。。
でも ＞データファイルの方は、個人プロフィールです。 ＞面接後に面接担当者が入力するケースが多いです。 や ＞作成者はデータを入力する人間なので、 ＞面接担当者それぞれが大半をしめておりますが、 ＞他の手すきの人間が行う場合もあります。
って事は、 詳細データの作成と管理ファイルの作成は別の人がする ＝ 同時に作成されない と言うことですよね・・・？
＞同時に複数の人間が使用することはありません。 入力するPCが一台しかないから、他の人は待たないといけない だから同時に使用される事はない とか言うこと？
(HANA)
seiyaさん
ありがとうございます！ 画像を必要に応じて表示させる方法って・・・ハイパーリンクとかですかね？ というよりは、全体的な具体的な方法もご教授頂きたいです☆
HANAさん
詳細データ入力も私が行う場合もあります。 というか、私一人にしようかと思っております（笑）
>って事は、 >詳細データの作成と管理ファイルの作成は別の人がする > ＝ 同時に作成されない >と言うことですよね・・・
ここも私の説明不足だったようです汗。。 もしくは、説明に一貫性がなかったかもしれませんね汗。。。 詳細データに入力したら自動的に管理ファイルにも入力されてほしいので、 作成自体は自動で行いたい・・・むしろ行われて欲しい。ですね。
(syus)
私の案ですとすべてマクロになりますよ？ (seiya)
seiyaさん
ですよね。。。 私自身がマクロをほとんど理解できていないのですが、、、 もし宜しければその上で教えて頂けると幸いです。
色々衝突しちゃいましたが（PCが不調で。。。） 大したことは書いてないですが、載せるだけ載せておきます。
＞というか、私一人にしようかと思っております（笑） と言うことなら、seiyaさんもコードを作りやすくなるのではないかと思います。
私のお伺いしたいことはひとまず聞き終えましたので 後はseiyaさんにお任せで。（笑）
syusさんも、頑張って下さいね。
(HANA)
HANAさん
ありがとうございました！ 投げっぱなしですいません。。。 マクロ、勉強しないと。。。。
詳しいデータ構成が必要です。
Sheet1の列項目 Sheet1のデータに対応させる、Sheet2のセル番地
(seiya)
seiyaさん
詳しいデータ構成ですね！
Sheet1(管理ファイル）列項目。左から列挙します。 氏名、フリガナ、路線、最寄駅、生年月日（西暦、月、日）、郵便番号、住所、電話番号、メールアドレス、銀行、支店（支店番号）、口座番号
Sheet2のセル番地。 左（氏名）から順番にこちらも列挙します。 E5、E3、E23、J23、G9（西暦）、K9（月）、M9（日）、E21、H21、G13、G17、E25、J25、S25
以上になります。 1点相談なんですが、生年月日のところを、入力した3箇所から1箇所のセルにまとめることはできますでしょうか？ 2008（G9）、10（K9）、20（M9）のように入力したものを2008/10/20のように一つのセルにしたいんですが・・・。 これが出来れば、生年月日のところのセルは1つで済むと思うので。
ではでは、宜しくお願い致します！！
(syus)
seiyaさん
連レスすいません。 登録する人数が増えるにつれて、シートの数が増えていく・・・ ことにしたいんですが、、、
というのも、面接シートに手書きされた内容は丸々データにも残しておきたいので。 その場合は、先程書いて頂いた手順の2）のところでコピーして新しいシートを作ればいいんですかね？？ Sheet1入力→Sheet2（面接シートフォーマット）に転送→Sheet2に未入力部分を入力後、新しいシートにコピー→Sheet2の入力部分消去→Sheet1入力→・・・ という感じでデータを増やしていけばマクロ構造上問題ないんですかね？？
だんだんこんがらがってきてしまいまして誠に申し訳ないです。。。
(syus)
> 面接シートに手書きされた内容は丸々データにも残しておきたいので。 この面接シートとはエクセルシートですか？
データフロー（データの流れ）をもう一度はっきりさせてもらえませんか？
1) 基礎データ入力（手書きデータをエクセルに入力/画像ファイルの保存) 2) 面接時入力（面接官による直接入力） 3) 基礎データの更新 とか... (seiya)
今日はここで落ちますので、後は明日になります。 (seiya)
seiyaさん
面接シートはエクセルシートです。 面接時にアウトして書き込むものです。 もしかして、ところどころで言葉のとらえ違いがあるんでしょうか汗。
データ作成の元になるのは、面接担当者が手書きで記入したシート（雛形はPCで作成したもの） なので、それを受け取って私がデータベース化させていきたいという狙いです。 面接シートが増える度にエクセルシートも増えるって認識は外れてないですよね？ なので、やりやすいやり方でお願いできればと思います。。。
HANAさんがおっしゃっていた、
>管理用ファイルに必要なデータは、先にそちらに入力して >そこから詳細データファイルを作成 >（この時、管理用ファイルに入力したダブっている項目のみ入力された状態） >その後、詳細データにのみ必要なデータ（空いている項目）＆写真を入力し 保存。 >と言う流れかと思います。
でも良いですし、最初に私が伝えたかった、
1）面接詳細データ入力（手書きデータをエクセルに入力/画像ファイルの保存) 2）管理データへ転送
でももちろん大丈夫です。 大分お手間を取らせてしまっているので、出来るだけやりやすい方でお願いできれば・・・ と思っております。
先のレスで一番伝えたかったのは、 新しい面接詳細データをどのように保存していけばいいのか？というところだったんです・・・。
ややこしくしてすいません汗。。
また明日、宜しくお願い致します。
(syus)
syusさんの中でイメージが湧いておられないようですので 少しだけ書いてみます。 細かい所はseiyaさんの処理方法になりますので 違ってくると思います。「こんな感じ～」で読んで下さい。 おそらく、そう違わないと思いますので。
詳細シート [A] [B] [C] [D] [E] [F] [1] ●フリガナ ●年 2009 ■■■■■ [2] ハナ ●月 3 ■ここに■ [3] ●氏名 ●日 12 ■写 真■ [4] HANA ■■■■■ [5] [6] ●郵便番号 [7] 000-0000 [8] ●住所 [9] 日本
データシート [A] [B] [C] [D] [E] [F] [1] フリガナ 氏名 郵便番号 住所 年月日 写真名 [2] ハナ HANA 000-0000 日本 2009/3/12 hana.jpg [3] [4]
管理シート [A] [B] [C] [D] [E] [1] 氏名 住所 [2] HANA 日本 [3]
まず、詳細シートでプロフィールを入力。 そして、[登録]すると、 データシートへデータが転記され 管理シートへ必要データが転記（リンク？）され 詳細シートのデータ（転記済み）は削除される
プロフィールの確認（データの変更）をしたい場合は・・・ 詳細シートにデータを呼び出す。（データシートからデータが参照され表示される） と言った構造です。
データシートへデータを転記するきっかけや 詳細シートにデータを呼び出す際のデータの指定方法を どの様にするかは、コード次第です。
そこで、seiyaさんの案を引用してみます。 ＞1) 管理ファイルのあるシート（Sheet1としましょう) にすべてのデータを蓄積 ＞2) 面接データはSheet1の名前をダブルクリックで面接シート(Sheet2としましょう）に転送 ＞3) 面接官の入力終了でSheet1をアップデート ＞4) 画像は別ファイルで保存し、必要に応じて表示
1)が、データシートになります。 詳細シートのいろいろなセルにばらばらに入力されたデータの情報をすべて 蓄積していきます。（リスト形式で。）
2)が、詳細シートにデータを呼び出す際のデータの指定方法 の案ですね。 データシート（あるいは管理シート）の指名をダブルクリックで 指定されたデータが、リスト形式で蓄積されているデータから抽出され 詳細シートの書式に則って表示されます。（一品一葉 です。）
3)が、データシートへデータを転記するきっかけ と言ったところでしょうか。 この流れの中では「変更・更新」という事になっていますが。
4)は、詳細シートに表示させる画像に関してです。 「別ファイルで保存し」が、どのような処理になさるのか分かりませんが とにかく、「このブックに保存しておかない」ということだと思います。 写真を保存するフォルダを決め (2)でデータをセットする際、 自動的に検索して 該当の写真を表示させる。
つまり ＞面接シートが増える度にエクセルシートも増えるって認識は外れてないですよね？ これが外れていて・・・・「意識改革が必要」と言いましたが 『リスト形式でデータを管理する』方法に変わります。
現在やっている方法は、一人に一枚ある詳細データの表を一枚ずつ管理ですよね。 そうではなく、一人の詳細データを、一行ずつにして管理。 人が見るときは、横にずらずらと並んだだけのデータは見にくいので それを見やすいように配置換えをして（詳細の表の配置にして）表示して見る。
たとえば、次にseiyaさんの面接が行われたら １．面接をした人から、seiyaさんのプロフィール＆写真が上がってくる （ここは 紙ベース。写真はデータでしょうけど。） ２．詳細シートにプロフィールを入力 （syusさんがデータ入力） ３．登録すると、 データシートの次の行（３行目）にseiyaさんの情報がすべて転記され 管理シートの次の行（３行目）にこのシートで必要なデータが転記され 詳細シートのデータは削除。
このときの「データシート」の状態のものが データベース化されたデータ と呼ぶにふさわしいものになると思います。
現在のように、一人一枚で作成されているものは 面接をした人が書いた紙の表よりも 字がきれいに書いてある紙でない表 と 大して変わりはありません。
面接詳細データの写真以外の情報が 一旦すべて別のところへ（形は変わりますが）保存されて 写真は写真だけで後から参照できる形で保存されていたら 入力した配置（一人一枚の形）で保存しておく必要はなくなりますよね。
もしも懸念しておられることが上記のことでない場合は さらりと「その事じゃないよ～」と書いてください。 無駄に紙面を使う気はありませんので。
ちなみにsyusさんが言っておられる 面接シート とは 【紙】に印刷された【用紙】に情報が記入された【紙】のことですよね。 （要するに 紙） シート といわれると、エクセルのシート（情報が入力されたもの）を 想像してしまいますが。。。 それでseiyaさんと話が行きつ戻りつするのかと？
(HANA)
HANAさん、どうも私には通訳が必要なのかもしれませんね...ありがとうございます。
syusさん、 HANAさんのご説明に付け加えるとすれば、[リスト]に予め面接官が記入する[備考欄]等を設けて 面接時に面接官の記入があれば、[リスト]の[備考欄]等を更新する。
つまり、[リスト]が重要で、面接シートは[リスト]から生成されるものです。
従って、シートの枚数は2枚のみ、を想定しています。
基礎データの打ち込みには、データフォーム/ユーザーフォームを使用したほうが便利だと思います。
それと、私が[ネットワーク]環境での使用かをお尋ねしたのは、どのようにして一つのExcelファイルを 面接官とsyusさんが共有するか不明だからです。 これにより、画像ファイルの処理の仕方が変わってきます。
PCは共有？ PCを共有しない場合、どのようにしてファイルを[共有]するのか？ (seiya)
HANAさん、seiyaさん
えーと・・・。 なんかお二人の話がかみ合いすぎていて、私の力不足・イメージ力の無さが恥ずかしいです。。。 HANAさん、ご丁寧な解説、本当にありがとうございます。
HANAさんの説明＋seiyaさんの付け加えて頂いたもので、完璧です。 実は私のイメージしているものが伝わりきれてないのかな・・・ とも思っていたんですが、私のイメージが沸いていなかったのが一番問題だったようですね汗。 「意識改革」は出来たはずなので、是非上記方法でよろしくお願いします。
データフォーム案は賛成です。 PCを共有するので、ファイル共有に関しては問題ないかと思われます。 さらに打ち込みも全て私が行うようにします。
(syus)
まず、HANAさんがサンプルデータを載せてシート構成を作表してくれていますね？ 各シート名も、データ、詳細 で統一しましょう。
そのような形で、もう一度詳しいシートレイアウトを投稿していただけませんか？ 詳細シートの日付（生年月日）は1セルに表示になるんですよね？ (seiya)
seiyaさん
詳細シートの生年月日は1セル表示でOKです！
シートレイアウトとは、前述した氏名がE3・・・みたいな感じで大丈夫ですか？ それとも・・・HANAさんが最初に書いてくれてるような・・・
>[A] [B] [C] [D] [E] [F] >[1] ●フリガナ ●年 2009 ■■■■■ >[2] ハナ ●月 3 ■ここに■ >[3] ●氏名 ●日 12 ■写 真■ >[4] HANA ■■■■■ >[5] >[6] ●郵便番号 >[7] 000-0000 >[8] ●住所 >[9] 日本
こっちですか？？
(syus)
それって、HANAさんの作成された表ですよね？
syusさんが現在持っている表です。 詳細、データ、両シートのレイアウトが必要です。 (seiya)
seiyaさん
了解です。
データシートはアドバイス頂いたとおり、項目だけの羅列が良いと思うので、 特にレイアウトはありません。
詳細シートに関しては、少々お時間頂きます。 出来ればデータでお送りしたいくらいですね（笑）
seiyaさん
お待たせ致しました。 こちらでいかがでしょうか？ 罫線がないとなんともわかりにくいものですね汗。。
[A] [B] [C] [D] [E] [F] [G] [H] [I] [1] フリガナ 性別 登録日 [2] 氏名 ■■■■■■■■■■ [3] ■ ■ [4] 生年月日 歳 ■ ■ [5] 携帯電話 ■ 写真貼付 ■ [6] 自宅電話 ■ ■ [7] 連絡先 自宅FAX ■ ■ [8] 携帯アドレス ■ ■ [9] PCアドレス ■■■■■■■■■■ [10] 現住所 〒 [11] 最寄駅 線 駅 自宅から最寄駅まで 分 [12] 振込先 銀行 支店 [13] 他登録会社 [14] 免許 資格 [15] 経歴 [16] アルバイト歴 [17] 身長 B W H 服のサイズ 号 足のサイズ
1) A1 にフリガナ、A2に氏名 と言う具合でよいのですか？（項目名は無し？）
2) 前出の[データ]シートの列項目以外の項目がありますが、無視してかまいませんか？
後で、ご自分で修正/補足するなら別ですが
3) 画像ファイル名の列は？
(seiya)
seiyaさん
>1) A1 にフリガナ、A2に氏名 と言う具合でよいのですか？（項目名は無し？）
A1にフリガナという項目名を入れて、B1～が空白（データ表示箇所）でお願いします。 記入したものは全て項目名になります。 HANAさんの例のように、全て記入した状態のほうがわかりやすいでしょうか？
>2) 前出の[データ]シートの列項目以外の項目がありますが、無視してかまいませんか？
後で、ご自分で修正/補足するなら別ですが
すいません。ここにある項目全てでお願いします。 全てOKと書いたのは、HANAさんの上記はあくまで例だと思いこんでいたからなので汗。 念のため、レイアウト式に書いておきます。 横が長くなりすぎてしまうので、適当に改行しておきました。。
[A] [B] [C] [D] [E] [F] [G] [H] [I]
[1] 氏名 フリガナ 性別 登録日 生年月日 年齢 携帯電話 自宅電話 自宅FAX
[J] [K] [L] [M] [N] [O] [P]
[1] 携帯アドレス PCアドレス 郵便番号 現住所 路線 最寄駅 銀行
[Q] [R] [S] [T] [U] [V] [1] 支店 他登録会社 免許 資格 経歴 アルバイト歴
[W] [X] [Y] [Z] [AA] [AB] [1] 身長 B W H 服のサイズ 足のサイズ
これで全て網羅できたかと思います。 関連して管理シートの項目も列挙しておきます。（若干の変更はありますが、前述とほぼ同じです。） なお管理シートにおいては、順番が変わっておりますが、ご了承ください。
氏名、フリガナ、路線、最寄駅、生年月日、郵便番号、住所、電話番号、携帯アドレス、銀行、支店、口座番号
>3) 画像ファイル名の列は？ G2でお願いします。
かなり不安ですが、意図する答えになってますでしょうか・・・。
> 自宅から最寄駅まで 分 データシートに対応する列がないような気がしますが、よろしいですか？ (seiya)
seiyaさん
おっと！すいません！！ [P]に挿入お願いできますでしょうか？
P列に[分]が入って、P以降が一列ずれてAC列に足のサイズですね？ AD列に画像ファイル名として、A列の名前に対応する画像ファイル名を入力してください。
1) このエクセルファイルのあるフォルダ（またはそのフォルダ内に新たに作成したフォルダ）内に
すべての画像ファイルを保存してください。
(seiya)
seiyaさん
そうです！！ 名前対応ってことは漢字で大丈夫ってことですね？
>1) このエクセルファイルのあるフォルダ（またはそのフォルダ内に新たに作成したフォルダ）内に
すべての画像ファイルを保存してください。
了解しました！
1) データシートのシート見出しを右クリック - [コードの表示] - 右空白部分に下記コードを貼り付け
上端右の x をクリックしてExcel画面に戻る
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim x As Long, i As Long, myAdd
If (Target.Column <> 1) + (Target.Row = 1) + (Target.Value = "") Then Exit Sub
Cancel = True
x = Target.Row
myAdd = "B2,B1,F1,H1,B4,F4,C5,C6,C7,C8,C9,B10,C10,B11,D11,G11" & _
",B12,D12,B13,B14,E14,B15,B16,B17,D17,F17,H17,J17,L17"
myAdd =Split(myAdd, ",")
With Sheets("詳細")
On Error Resume Next
.Pictures.Delete
On Error GoTo 0
For i = 0 To UBound(myAdd)
.Range(myAdd(i)).Value = Me.Cells(x, i + 1).Value
Next
If Dir(ThisWorkbook.Path & "\" & Me.Cells(x, "AD").Value) <> "" Then
.Pictures.Insert(ThisWorkbook.Path & "\" & Me.Cells(x, "AD").Value)
Set myPic = .Pictures(.Pictures.Count)
myPic.Left = .Columns("G").Left
myPic.Top = .Rows(2)
myPic,Height = 40
myPic.Width = 40
End If
.Select
End With
End Sub
2) A列の名前をダブルクリックして試してください。
上記コードは画像ファイルがエクセルファイルと同じフォルダにあることを前提としています。 画像のサイズについては Height, Width の値（40）を調整してください。 (seiya) 修正 追加行あり 17:03
seiyaさん
コンパイルエラー Sub、Function、またはPropertyが必要です。
と表示されてしまいました。 A2に〝あああ”と入力し、AD2に”あああ.jpg”と入力してあります。
修正頂いたもので試して見たんですが・・・
また修正しましたので、もう一度コピーして試してください。 (seiya)
seiyaさん
再度コピペ後チャレンジしたんですが、 同じエラーが出てしまいました。
myAdd = "B2,B1,F1,H1,B4,F4,C5,C6,C7,C8,C9,B10,C10,B11,D11,G11" & _
",B12,D12,B13,B14,E14,B15,B16,B17,D17,F17,H17,J17"
一応、上記の部分に対応するように詳細シートは作成済みです。 足のサイズに対応するセルがないような気がするんですが・・・。
Sheet2に詳細シート、Sheet1にデータシートでいいんですよね？
自分で[詳細]シートにしましょうと言って、Sheet2にしていました。 すみません。 確認です、詳細 です。詳細シート ではありませんので... 足のサイズは L17 でよいですね? もう一度試してください。 (seiya)
seiyaさん
実は先程までシート名はSheet2になってました（笑） 現在のシート名は・・・
Sheet1、詳細
となっております。 Sheet1に入力で大丈夫ですよね？
ここまではそれで大丈夫です。 コードを修正していますので、もう一度コピーして試して下さい。 まずこの部分を完成させましょう。 (seiya)
seiyaさん
たびたびすいません。 頭が下がります。
もう一度更新してみましたが・・・ 同じエラーです。
どこかまずいところがあるんでしょうか・・・？？
> コンパイルエラー > Sub、Function、またはPropertyが必要です。 が出るのですか？ (seiya)
はい。 1行目が黄色くなるのも変わっていません。
面倒ですがひとつずつ見ていきましょう。
下記に差し替えて、試してください。
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim x As Long, i As Long, myAdd
If (Target.Column <> 1) + (Target.Row = 1) + (Target.Value = "") Then Exit Sub
Cancel = True
x = Target.Row
myAdd = "B2,B1,F1,H1,B4,F4,C5,C6,C7,C8,C9,B10,C10,B11,D11,G11" & _
",B12,D12,B13,B14,E14,B15,B16,B17,D17,F17,H17,J17,L17"
myAdd =Split(myAdd, ",")
With Sheets("詳細")
For i = 0 To UBound(myAdd)
.Range(myAdd(i)).Value = Me.Cells(x, i + 1).Value
Next
.Select
End With
End Sub
(seiya)
seiyaさん
面倒なんてとんでもないです！！
今回はエラーは出ませんでした！ そして詳細に見事に入りました！！
ということは後半部分ですね...
これでどうでしょう？
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim x As Long, i As Long, myAdd, myPic As Object
If (Target.Column <> 1) + (Target.Row = 1) + (Target.Value = "") Then Exit Sub
Cancel = True
x = Target.Row
myAdd = "B2,B1,F1,H1,B4,F4,C5,C6,C7,C8,C9,B10,C10,B11,D11,G11" & _
",B12,D12,B13,B14,E14,B15,B16,B17,D17,F17,H17,J17,L17"
myAdd =Split(myAdd, ",")
With Sheets("詳細")
On Error Resume Next
.Pictures.Delete
On Error GoTo 0
For i = 0 To UBound(myAdd)
.Range(myAdd(i)).Value = Me.Cells(x, i + 1).Value
Next
If Dir(ThisWorkbook.Path & "\" & Me.Cells(x, "AD").Value) <> "" Then
.Pictures.Insert(ThisWorkbook.Path & "\" & Me.Cells(x, "AD").Value)
Set myPic = .Pictures(.Pictures.Count)
myPic.Left = .Columns("G").Left
myPic.Top = .Rows(2).Top
myPic.Height = 40
myPic.Width = 40
End If
.Select
End With
End Sub
(seiya)
seiyaさん
実行時エラー'1004':
PictureクラスのTOPプロパティを設定できません。
と表示されました。 ただ、詳細に氏名と画像は入りました☆
追記すいません！
myPic.Top = .Rows(2)
この部分が黄色くなってますね。
いけね、
myPic.Top = .Rows(2).Top
に変更してください。 元コードは変更しておきます。 (seiya)
もう一か所
「myPic,Height = 40」
~カンマになってますよ。
(HANA)
HANAさんどうもです。 修正しておきます。 (seiya)
HANAさん、seiyaさん
カンマ、修正しました。 無事に飛びました！！
写真の大きさは適当にしてみますね！
この先は明日になります。 (seiya)
seiyaさん
今日も長時間ありがとうございました！！ 次にPCをいじれるのが月曜日なので、月曜でお願いしてもよろしいですか？？
月曜は忙しいので、火曜日以降になります。 (seiya)
seiyaさん
わかりました。 よろしくお願い致します。
syusさん
次のステップに行く前に以下の項目の確認をしてください。
1) 基礎データの入力 (syusさん)
2) データの閲覧 (面接官)
これは、プリントしたものですか？ それともPCで？
3) 面接後、基礎データの更新 (syusさんがどのようにして？）
なるべく具体的に、こちらにも状況がわかるように説明してください。 (seiya)
seiyaさん
1)これは入力を済ませておくということでしょうか？
2)閲覧はどちらでもありえます。 PC上で確認することもあれば、プリントアウトして持ち出すこともあるということです。
3)すいません。基礎データは詳細のことと考えてよろしいでしょうか？ データ更新までの流れは、 面接終了→手書き面接シートを受けとる→syusが入力という流れにしました。 なので、データの更新に関しては私が全て行います。
いかがでしょうか？ 今日もよろしくお願い致します。
(syus)
まず、データシートの名前を データ にして、現在書かれているコードを削除してください。
1) 以下のコードを データ シートのモジュールへ
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim x As Long, i As Long, myAdd, myPic As Object
If (Target.Column <> 1) + (Target.Row = 1) + (Target.Value = "") Then Exit Sub
Application.EnableEvents = False
Cancel = True
x = Target.Row
myAdd = "B2,B1,F1,H1,B4,F4,C5,C6,C7,C8,C9,B10,C10,B11,D11,G11" & _
",B12,D12,B13,B14,E14,B15,B16,B17,D17,F17,H17,J17,L17"
myAdd =Split(myAdd, ",")
With Sheets("詳細")
On Error Resume Next
.Pictures.Delete
On Error GoTo 0
For i = 0 To UBound(myAdd)
.Range(myAdd(i)).Value = Me.Cells(x, i + 1).Value
Next
If Dir(ThisWorkbook.Path & "\" & Me.Cells(x, "AD").Value) <> "" Then
.Pictures.Insert(ThisWorkbook.Path & "\" & Me.Cells(x, "AD").Value)
Set myPic = .Pictures(.Pictures.Count)
myPic.Left = .Columns("G").Left
myPic.Top = .Rows(2).Top
myPic.Height = 40
myPic.Width = 40
End If
End With
Application.EnableEvents = True
Sheets("詳細").Select
End Sub
Private Sub Worksheet_Deactivate()
Range("a2", Range("a" & Rows.Count).End(xlUp)).Name = "myNames"
End Sub
- - - - - - - - - -
2) 以下のコードを 詳細シートのモジュールへ
Private Sub Worksheet_Activate()
With Range("b2")
.Validation.Delete
.Validation.Add type:= xlValidateList, formula1:= "=myNames"
End With
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim x
If Target.Address <> "B2" Then Exit Sub
Application.EnableEvents = False
If IsEmpty(Target.Value) Then
Range("B1,F1,H1,B4,F4,C5,C6,C7,C8,C9,B10,C10,B11,D11,G11" & _
",B12,D12,B13,B14,E14,B15,B16,B17,D17,F17,H17,J17,L17").ClearContents
On Error Resume Next
Me.Pictures.Delete
Else
x = Application.Match(Target.Value, Sheets("データ").Columns(1), 0)
MsgBox x
If Not IsError(x) Then myDataTransfer(x)
End If
Application.EnableEvents = True
End Sub
Function myDataTransfer(ByVal rowNum)
Dim myAdd, i As Long
myAdd = "B1,F1,H1,B4,F4,C5,C6,C7,C8,C9,B10,C10,B11,D11,G11" & _
",B12,D12,B13,B14,E14,B15,B16,B17,D17,F17,H17,J17,L17"
myAdd = Split(myAdd, ",")
With Sheets("詳細")
For i = 0 To UBound(myAdd)
.Range(myAdd(i)).Value = Sheets("データ").Cells(rowNum, i + 2).Value
Next
On Error Resume Next
.Pictures.Delete
On Error GoTo 0
If Dir(ThisWorkbook.Path & "\" & Sheets("データ").Cells(rowNum, "AD").Value) <> "" Then
.Pictures.Insert(ThisWorkbook.Path & "\" & Sheets("データ").Cells(rowNum, "AD").Value)
Set myPic = .Pictures(.Pictures.Count)
myPic.Left = .Columns("G").Left
myPic.Top = .Rows(2).Top
myPic.Height = 40
myPic.Width = 40
End If
End With
End Sub
(seiya)
詳細シートのB2に入力規則でリストができるはずです。 リストから名前を選択すると、データが切り替わると思いますので試してください。 (seiya)
seiyaさん
早速試してみました。 詳細シートのB2にリストはできましたが、 選択肢がmyNamesというものしか出てきません。
データシートの方を全項目入力できていないと出てこないとか、 そういった類のしばりがあるのでしょうか？
(syus)
.Validation.Add type:= xlValidateList, formula1:= "=myNames"
^^
が抜けていました。
(seiya)
seiyaさん
名前、選択できるようになりました！ ただ、その他の情報が変更されません。
名前を選択すると、その他の情報も詳細に反映されるはずですよね？
(syus)
おっと、 Function myDataTransfer をもう一度コピーして差し替えてください。 (seiya)
seiyaさん
差し替えました！ が・・・状況変わらずです。 詳細シートのモジュールの、 Function myDataTransfer(ByVal rowNum)以下を差し替えている状態です。
(syus)
修正しましたのでもう一度差し替えてください。 (seiya)
seiyaさん
差し替えました。 表示されません。。。 前回同様の部分を差し替えた状態です。
付け加えて、二人目以降のデータが詳細へ反映できません。 二人目の氏名をダブルクリックすると・・・
実行時エラー1004 PictureクラスのInsertメソッドが失敗しました。
と出てしまいました。 .Pictures.Insert (ThisWorkbook.Path & "\" & Me.Cells(x, "AD").Value) この部分が黄色くなっております。
(syus)
> 実行時エラー1004 > PictureクラスのInsertメソッドが失敗しました そちらのコードは殆どいじっていないので、なぜそのようなエラーが発生するのか不明です。 一度、詳細のモジュールのコードをすべて削除して、試してください（ダブルクリック）。 (seiya)
seiyaさん
申し訳ありません。 最初にご注意いただいた、写真ファイルがなかったせいでした。 問題はなさそうです。
(syus)
? 写真ファイルがそのフォルダになくてもエラーにならないように記述してあるのですが？ (seiya)
seiyaさん
データシートの画像ファイル名に入力すらしてなかったんです汗。。 入力したらあああと同じように反映できるようになりました。 お手数かけて申し訳ないです汗。。
(syus)
それでは、詳細シートの方へ...
Change イベントコードを下記に差し替えてメッセージを読んでください。
Private Sub Worksheet_Change(ByVal Target As Range)
Dim x
If Target.Address <> "B2" Then Exit Sub
Application.EnableEvents = False
If IsEmpty(Target.Value) Then
Range("B1,F1,H1,B4,F4,C5,C6,C7,C8,C9,B10,C10,B11,D11,G11" & _
",B12,D12,B13,B14,E14,B15,B16,B17,D17,F17,H17,J17,L17").ClearContents
On Error Resume Next
Me.Pictures.Delete
Else
x = Application.Match(Target.Value, Sheets("データ").Columns(1), 0)
MsgBox x
If Not IsError(x) Then myDataTransfer(x)
End If
Application.EnableEvents = True
End Sub
(seiya)
seiyaさん
すいません。 メッセージを読んでください。の意味がわからないんですが・・・。 詳細シートのコードの、指定の部分は差し替えました。
(syus)
コードを差し替えて B2 から名前を選択するとメッセージが出ると思いますが？ (seiya)
seiyaさん
出ないですね・・・。
(syus)
データシートのダブルクリックはできますか？ おそらくダブルクリックしてもデータは変わらないでしょう...
VBE画面で
1) [表示] - [イミディエイトウィンド]
2) コード枠の下部に新たな枠ができるますので、その中に
Application.EnableEvents = True
として、Enterキーを押してください。
3) これで、機能すると思います。
(seiya)
seiyaさん
ダブルクリックはできています。 データの反映もできています。 上記方法は出来ている場合は追加しないほうがよいのですか？ 今後も過程的にあったほうが便利ならば、追加しておきます☆
(syus)
> 実行時エラー1004 > PictureクラスのInsertメソッドが失敗しました。 になったのですよね？ この段階で EnableEvents は False にセットされたままのはずです....
もし、ダブルクリックが正常に機能しているのなら詳細のB2(ドロップダウン)を変更したときに メッセージが出ると思います。 コードは削除していませんよね？ (seiya)
seiyaさん
>> 実行時エラー1004 >> PictureクラスのInsertメソッドが失敗しました。 >になったのですよね？ >この段階で EnableEvents は False にセットされたままのはずです....
このエラーが表示されたのは写真のファイル名を入力していなかった時の話です。 ので、今は表示されません。 コードは、ご指示頂いた部分以外は修正しておりません。 その他、原因は考えられますでしょうか・・・汗。。 Application.EnableEvents = False になっております。。。
(syus)
現状はどのようになっているのでしょう？
違う名前をダブルクリックして、（画像ファイル名が無い名前でも結構です）データが変更されるか 確認してください。 (seiya)
seiyaさん
画像ファイル名が無い状態ですと、先程と同じ実行時エラー1004がでます。 ただ、氏名その他の内容は詳細シートに反映されています。 ちなみに・・・
> VBE画面で >1) [表示] - [イミディエイトウィンド] >2) コード枠の下部に新たな枠ができるますので、その中に > Application.EnableEvents = True > として、Enterキーを押してください。 >3) これで、機能すると思います。
これは実行済みです。 画像ファイル名を入れた状態だと、エラーは出ません。 そして名前を選択しなおしても、変更されません。 〝いいい"を選んでも、表示されている他のデータは"あああ"のまま、 という状況です。 伝わりました？？汗。。。
(syus)
そうですか... ファイル名が無い場合でもエラーにならに様にしないといけないのですが これで試してください。
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim x As Long, i As Long, myAdd, myPic As Object, myFile As String
If (Target.Column <> 1) + (Target.Row = 1) + (Target.Value = "") Then Exit Sub
Application.EnableEvents = False
Cancel = True
x = Target.Row
myAdd = "B2,B1,F1,H1,B4,F4,C5,C6,C7,C8,C9,B10,C10,B11,D11,G11" & _
",B12,D12,B13,B14,E14,B15,B16,B17,D17,F17,H17,J17,L17"
myAdd =Split(myAdd, ",")
With Sheets("詳細")
On Error Resume Next
.Pictures.Delete
'On Error GoTo 0
For i = 0 To UBound(myAdd)
.Range(myAdd(i)).Value = Me.Cells(x, i + 1).Value
Next
myFile = Dir(ThisWorkbook.Path & "\" & Me.Cells(x, "AD").Value)
If myFile <> "" Then
.Pictures.Insert(ThisWorkbook.Path & "\" & myFile)
Set myPic = .Pictures(.Pictures.Count)
myPic.Left = .Columns("G").Left
myPic.Top = .Rows(2).Top
myPic.Height = 40
myPic.Width = 40
End If
End With
Application.EnableEvents = True
Sheets("詳細").Select
End Sub
(seiya)
seiyaさん
ファイル名を未入力でもエラーは表示されなくなりました。 ただ、ファイル名未入力の場合に、〝いいい"をダブルクリックしても、 "あああ"の写真が表示されてしまいます。
上記コードの下に、
Private Sub Worksheet_Deactivate()
Range("a2", Range("a" & Rows.Count).End(xlUp)).Name = "myNames"
End Sub
は、あったままでいいんですよね？
ドロップダウンから名前を選択してもデータが変わらない状態もそのままです。 他にも試したほうがいい条件等あればお願いします！ (syus)
まず、上記コードを完成させましょう。 コードをもう一度コピーして差し替えて実行してください。 その他のコードはそのままで結構です。
うまく動く場合はいろいろな名前をクリックして試して下さい。 (seiya)
seiyaさん
コード差し替え実行しました。 〝いいい"ダブルクリックで"あああ"の写真表示現象は変わらずです。 （"いいい"写真ファイル名無しの場合） 念のため、現状のデータシートのコードを載せておきます。
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim x As Long, i As Long, myAdd, myPic As Object, myFile As String
If (Target.Column <> 1) + (Target.Row = 1) + (Target.Value = "") Then Exit Sub
Application.EnableEvents = False
Cancel = True
x = Target.Row
myAdd = "B2,B1,F1,H1,B4,F4,C5,C6,C7,C8,C9,B10,C10,B11,D11,G11" & _
",B12,D12,B13,B14,E14,B15,B16,B17,D17,F17,H17,J17,L17"
myAdd = Split(myAdd, ",")
With Sheets("詳細")
On Error Resume Next
.Pictures.Delete
'On Error GoTo 0
For i = 0 To UBound(myAdd)
.Range(myAdd(i)).Value = Me.Cells(x, i + 1).Value
Next
myFile = Dir(ThisWorkbook.Path & "\" & Me.Cells(x, "AD").Value)
If myFile <> "" Then
.Pictures.Insert (ThisWorkbook.Path & "\" & myFile)
Set myPic = .Pictures(.Pictures.Count)
myPic.Left = .Columns("G").Left
myPic.Top = .Rows(2).Top
myPic.Height = 40
myPic.Width = 40
End If
End With
Application.EnableEvents = True
Sheets("詳細").Select
End Sub
Private Sub Worksheet_Deactivate()
Range("a2", Range("a" & Rows.Count).End(xlUp)).Name = "myNames"
End Sub
(syus)
こちらで試してください。
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim x As Long, i As Long, myAdd, myPic As Object, myFile As String
If (Target.Column <> 1) + (Target.Row = 1) + (Target.Value = "") Then Exit Sub
Application.EnableEvents = False
Cancel = True
x = Target.Row
myAdd = "B2,B1,F1,H1,B4,F4,C5,C6,C7,C8,C9,B10,C10,B11,D11,G11" & _
",B12,D12,B13,B14,E14,B15,B16,B17,D17,F17,H17,J17,L17"
myAdd = Split(myAdd, ",")
With Sheets("詳細")
'On Error Resume Next
.Pictures.Delete
On Error GoTo 0
For i = 0 To UBound(myAdd)
.Range(myAdd(i)).Value = Me.Cells(x, i + 1).Value
Next
myFile = Dir(ThisWorkbook.Path & "\" & Me.Cells(x, "AD").Value)
If myFile <> "" Then
.Pictures.Insert (ThisWorkbook.Path & "\" & myFile)
Set myPic = .Pictures(.Pictures.Count)
myPic.Left = .Columns("G").Left
myPic.Top = .Rows(2).Top
myPic.Height = 40
myPic.Width = 40
End If
End With
Application.EnableEvents = True
Sheets("詳細").Select
End Sub
Private Sub Worksheet_Deactivate()
Range("a2", Range("a" & Rows.Count).End(xlUp)).Name = "myNames"
End Sub
(seiya)
seiyaさん
差し替えました。 状況変わらずです。。。 写真ファイル名がない名前をダブルクリックすると、あああの写真が表示されます。
試しに"あああ"の写真ファイル名を消してダブルクリックしてみたんですが、 やはり"あああ"の写真が表示されました。
さらに試しに、フォルダ内から写真ファイルを全部外に出したところ、 先程のエラー1004が表示されます。 黄色くなる部分も先程と同じでした。
(syus)
> 試しに"あああ"の写真ファイル名を消してダブルクリックしてみたんですが、 > やはり"あああ"の写真が表示されました。
"あああ"の写真が残っていた。ということでしょうか？ これで試してください。
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim x As Long, i As Long, myAdd, myPic As Object, myFile As String
If (Target.Column <> 1) + (Target.Row = 1) + (Target.Value = "") Then Exit Sub
Application.EnableEvents = False
Cancel = True
x = Target.Row
myAdd = "B2,B1,F1,H1,B4,F4,C5,C6,C7,C8,C9,B10,C10,B11,D11,G11" & _
",B12,D12,B13,B14,E14,B15,B16,B17,D17,F17,H17,J17,L17"
myAdd = Split(myAdd, ",")
With Sheets("詳細")
'On Error Resume Next
.Pictures.Delete
On Error GoTo 0
MsgBox .Pictures.Count
For i = 0 To UBound(myAdd)
.Range(myAdd(i)).Value = Me.Cells(x, i + 1).Value
Next
myFile = Dir(ThisWorkbook.Path & "\" & Me.Cells(x, "AD").Value)
If myFile = Me.Cells(x, "AD").Value Then
.Pictures.Insert (ThisWorkbook.Path & "\" & myFile)
Set myPic = .Pictures(.Pictures.Count)
myPic.Left = .Columns("G").Left
myPic.Top = .Rows(2).Top
myPic.Height = 40
myPic.Width = 40
End If
End With
Application.EnableEvents = True
Sheets("詳細").Select
End Sub
(seiya)
seiyaさん
残っていたわけではなく、新たに表示されていました。
今回のコードに差し替えました。 ダブルクリックすると、"0"と表示され、OKをクリックすると、 詳細にジャンプしました。 写真ファイル名未記入の"いいい"をダブルクリックしても、 同様に"0"と表示され、OKをクリックすると詳細にジャンプしました。 写真は表示されませんでした！！ 1歩前進でしょうか☆
(syus)
前進したようです。 しかし、Pictures.Count が 0 ということは Pictures.Delete が機能しないということです。
.Picitures.Delete の行を .Shapes.Delete にして試してください。 (seiya)
seiyaさん
'On Error Resume Next .Pictuers.Delete→.Shapes.Delete On Error GoTo 0
→部分だけ変更でいいんですよね？ まだ他にも修正箇所ってありました？？ 修正後、ダブルクリックすると・・・
実行時エラー438 オブジェクトは、このプロパティまたはメソッドをサポートしていません。
と標記されてしまいました汗。。
(syus)
seiyaさん
追記です。すいません！ エラー箇所は修正部分の.Shapes.Deleteでした！！
> 前進したようです。 > しかし、Pictures.Count が 0 ということは Pictures.Delete が機能しないということです。 違いますね.... 0 ということは、Pictures.Delete が機能したか、あるいは Pictures コレクションを取得できないか のいずれかでしょうね...
.Pictures.Delete
が機能しなければお手上げ状態ですね...
詳細シートに画像を貼り付けて 先ほどのイミディエイトウィンドに
Sheets("詳細").Pictures.Delete
としてEnter
で詳細シートの画像が削除されるかどうか確認してください。 (seiya)
seiyaさん
無事に削除されました！！ よかったです。。。
(syus)
これでもう一度徹底的に試して下さい。 まずこれが機能しなければ、先へ進めませんので..
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim x As Long, i As Long, myAdd, myPic As Object, myFile As String
If (Target.Column <> 1) + (Target.Row = 1) + (Target.Value = "") Then Exit Sub
Application.EnableEvents = False
Cancel = True
x = Target.Row
myAdd = "B2,B1,F1,H1,B4,F4,C5,C6,C7,C8,C9,B10,C10,B11,D11,G11" & _
",B12,D12,B13,B14,E14,B15,B16,B17,D17,F17,H17,J17,L17"
myAdd = Split(myAdd, ",")
With Sheets("詳細")
.Select
On Error Resume Next
.Pictures.Delete
On Error GoTo 0
MsgBox .Pictures.Count
For i = 0 To UBound(myAdd)
.Range(myAdd(i)).Value = Me.Cells(x, i + 1).Value
Next
myFile = Dir(ThisWorkbook.Path & "\" & Me.Cells(x, "AD").Value)
If myFile = Me.Cells(x, "AD").Value Then
.Pictures.Insert (ThisWorkbook.Path & "\" & myFile)
Set myPic = .Pictures(.Pictures.Count)
myPic.Left = .Columns("G").Left
myPic.Top = .Rows(2).Top
myPic.Height = 40
myPic.Width = 40
End If
End With
Application.EnableEvents = True
End Sub
(seiya)
seiyaさん
試してみました。 まだ0と表示されてしまいますね。
ただ、前回と変わった点がありまして、 前回はダブルクリックしたシート、すなわちデータシート上で0が表示され、 OKをクリック後に詳細シートに移っていたのですが、 今回はダブルクリックした段階で、詳細シートに移り、 0が表示されます。 そしてOKをクリックすると、一瞬残像のように大きい画像が表示され、 （おそらく画像ファイルの大きさがそのまま出てるのかと） その後、所定サイズになる。
といった感じの現象が起きています。
いかがでしょうか。。。
(syus)
> まだ0と表示されてしまいますね。
MsgBox .Pictures.Count
の行を削除してください。
まだ画像ファイル名の無い名前をクリックしたとき、画像が残ってますか？ (seiya)
seiyaさん
0表示（メッセージボックス）、消えました。
>まだ画像ファイル名の無い名前をクリックしたとき、画像が残ってますか？ いえ、画像は表示されなくなりました。 そしてエラーも出なくなってます☆
(syus)
詳細シートへ
Private Sub Worksheet_Activate()
With Range("b2")
.Validation.Delete
.Validation.Add type:= xlValidateList, formula1:= "=myNames"
End With
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim x
If Target.Address(0,0) <> "B2" Then Exit Sub
Application.EnableEvents = False
Range("B1,F1,H1,B4,F4,C5,C6,C7,C8,C9,B10,C10,B11,D11,G11" & _
",B12,D12,B13,B14,E14,B15,B16,B17,D17,F17,H17,J17,L17").ClearContents
On Error Resume Next
Me.Pictures.Delete
On Error GoTo 0
x = Application.Match(Target.Value, Sheets("データ").Columns(1), 0)
If IsNumeric(x) Then
myDataTransfer(x)
Else
MsgBox x
End If
Application.EnableEvents = True
End Sub
Function myDataTransfer(ByVal rowNum)
Dim myAdd, i As Long, myFile As String
myAdd = "B1,F1,H1,B4,F4,C5,C6,C7,C8,C9,B10,C10,B11,D11,G11" & _
",B12,D12,B13,B14,E14,B15,B16,B17,D17,F17,H17,J17,L17"
myAdd = Split(myAdd, ",")
With Sheets("詳細")
For i = 0 To UBound(myAdd)
.Range(myAdd(i)).Value = Sheets("データ").Cells(rowNum, i + 2).Value
Next
On Error Resume Next
.Pictures.Delete
On Error GoTo 0
myFile = Dir(ThisWorkbook.Path & "\" & Sheets("データ").Cells(rowNum, "AD").Value)
If myFile = Sheets("データ").Cells(rowNum, "AD").Value Then
.Pictures.Insert(ThisWorkbook.Path & "\" & myFile)
Set myPic = .Pictures(.Pictures.Count)
myPic.Left = .Columns("G").Left
myPic.Top = .Rows(2).Top
myPic.Height = 40
myPic.Width = 40
End If
End With
End Function
詳細シートの B2(ドロップダウン)名前を変更して動作を確認してください。 (seiya)
seiyaさん
詳細シートのコード、差し替えました。 が、変わらないですね。。。
状況としては、いくつかデータシートからダブルクリックでデータを飛ばした後に、 ドロップダウンで名前を変更しているんですが・・・
(syus)
そのはずでした...
If Target.Address(0,0) <> "B2" Then Exit Sub
^^^^^
が抜けていたので、コード自体が実行されいませんでした。
もう一度コピーして試してください。 (seiya)
seiyaさん
指定部分、挿入しました。 結果・・・
ドロップダウンで表示されている以外の名前を選ぶと、
コンパイルエラー 構文エラー
と表示され、
Function myDataTransfer(ByVal rowNum)の部分が黄色くなり、
If myFile = Sheets("データ").Cells(rowNum, "AD").Value) Then
の部分が選択された状態になります。
(syus)
")" が余分でした
If myFile = Sheets("データ").Cells(rowNum, "AD").Value Then
にならないといけませんでした
(seiya)
seiyaさん
上記訂正いたしました！ その後、ドロップダウンから名前を変えると・・・
コンパイルエラー End Functionが必要です。
と出てきました。 黄色くなっている部分は前回と同様。 選択されている部分は最後の行のEnd Subの部分です。 ただ、前回のように選択部分が赤文字になっているということはありません。
(syus)
Function の最後の行が End Sub になっていましたので End Function に変更してください。 コードは変更してあります。 (seiya)
seiyaさん
ドロップダウンでばっちり変わるようになりました！ 写真も表示されております☆ そしてエラーも出なくなりました！！
(syus)
seiyaさん
今日はもう上がられたんでしょうか？ 今日も長い時間ありがとうございました！！
またよろしくお願い致します☆
(syus)
syusさん 昨日は予告もなく落ちてしまいましてすみませんでした。
さて、現段階までの状況が改善されたようですね？
エラー無く、きちんと作動しているのであれば次へ進みますがよろしいですか？ (seiya)
seiyaさん
おはようございます。 お気になさらないでください！
今までの所は大丈夫になっていると思います☆
今日もよろしくお願い致します。
(syus)
syusさんのデータ入力方法に付いて...
現在詳細シートからドロップダウンを利用してデータシートから該当データを抽出していますが 詳細シートからデータの編集、および新規データの追加を考えています。
上記はsyusさんだけが行うことで...
ThisWorkbook モジュールへ Excelのメニューバーの編集の左隣にあるエクセルアイコンを右クリックして-[コードの表示]
Public ItsMe As Boolean
Private Sub Workbook_Open()
ItsMe = (InputBox("どなたですか？") = "syus")
If ItsMe Then
Sheets("データ").Visible = xlSheetVisible
Else
Sheets("データ").Visible = xlSheetVeryHidden
End If
End Sub
- - - - - - - - - - - - - -
詳細シートの Change イベントコードを下記と差し替えてください。
Private myUpdate As Boolean
Private Sub Worksheet_Change(ByVal Target As Range)
Dim x
If Target.Address(0,0) <> "B2" Then Exit Sub
Application.EnableEvents = False
Range("B1,F1,H1,B4,F4,C5,C6,C7,C8,C9,B10,C10,B11,D11,G11" & _
",B12,D12,B13,B14,E14,B15,B16,B17,D17,F17,H17,J17,L17").ClearContents
On Error Resume Next
Me.Pictures.Delete
On Error GoTo 0
x = Application.Match(Target.Value, Sheets("データ").Columns(1), 0)
If IsNumeric(x) Then
myDataTransfer(x)
Else
If ItsMe Then
If vbYes = MsgBox(.Value & vbLf & "を追加しますか？",vbYesNo + vbQestion) Then
Sheets("データ").Range("a" & Rows.Count).End(xlUp)(2).Value = Target.Value
myUpdate = True
Else
Target.ClearContents
End If
End If
End If
Application.EnableEvents = True
End Sub
Private Sub Worksheet_Deactivate()
Dim myAdd, i As Long, x
If myUpdate Then
x = Application.Match(Me.Range("b2").Value, Sheets("データ").Columns(1), 0)
If IsNumeric(x) Then
myAdd = "B1,F1,H1,B4,F4,C5,C6,C7,C8,C9,B10,C10,B11,D11,G11" & _
",B12,D12,B13,B14,E14,B15,B16,B17,D17,F17,H17,J17,L17"
myAdd = Split(myAdd, ",")
With Sheets("データ")
For i = 0 To UBound(myAdd)
.Cells(x, i + 2).Value = Me.Range(myAdd(i)).Value
Next
End With
End If
myUpdate = False
End If
End Sub
ファイルをSaveして、一旦閉じ、再度開いてください。 MsgBoxが出ますので syus と入力してください。 詳細シートのB2にリストに無い名前を入力してみてください。 (seiya)
seiyaさん
ブックを開いて、syusと入力するところまではOKでした。 ただ、詳細シートを表示しようとすると、
コンパイルエラー End Sub、End FunctionまたはEnd Property以降にはコメントのみが表示できます。
と表示されます。
Private Sub Worksheet_Activate()←この部分が黄色くなっております。
With Range("b2")
.Validation.Delete
.Validation.Add Type:=xlValidateList, Formula1:="=myNames"
End With
End Sub
Private myUpdate As Boolean←この部分が選択されます。
Private Sub Worksheet_Change(ByVal Target As Range) Dim x If Target.Address(0, 0) <> "B2" Then Exit Sub・・・以下略
という流れであってますか？ 詳細シートを開く段階でエラーが出てしまうので、 B2に入力して確認はしていない状態です。
(syus)
Private myUpdate As Boolean の行があると思いますが、これは一番上 一行目 に位置する必要があります。
途中にある場合は、その行をカットして一行目に貼り付けてください。 (seiya)
seiyaさん
上記このように修正しました。 合ってますか？？
Private myUpdate As Boolean
Private Sub Worksheet_Activate()
With Range("b2")
.Validation.Delete
.Validation.Add Type:=xlValidateList, Formula1:="=myNames"
End With
End Sub
Private Sub Worksheet_Change(ByVal Target As Range) Dim x If Target.Address(0, 0) <> "B2" Then Exit Sub・・・以下略
詳細シートを選択しても、エラーは出なくなりました。 ただ、詳細シートで名前を選択しようとすると、
コンパイルエラー 参照が不正または不完全です。
と表示され、
Private Sub Worksheet_Change(ByVal Target As Range)の部分が黄色くなり、 If vbYes = MsgBox(.Value・・・←このValueの部分が選択されています。
ちなみに、B2に無い名前を入力すると・・・
入力した値は正しくありません。 ユーザーの設定によってセルに入力できる値が制限されています。
と表示され、再試行とキャンセルを選ぶようになっています。 そしてキャンセルをクリックすると、上記と同じエラーが出ます。
(syus)
Activate イベントコードを下記に差し替えてください。
Private Sub Worksheet_Activate()
With Range("b2").Validation
.Delete
.Add type:= xlValidateList, formula1:= "=myNames"
.ShowError = False
.InCellDropDown = False
End With
End Sub
(seiya)
昼食にします
seiyaさん
上記差し替えました。 状況変わらずです・・・
念のため、現状の詳細シートのコードを書き込んでおきます。
Private myUpdate As Boolean
Private Sub Worksheet_Activate()
With Range("b2").Validation
.Delete
.Add Type:=xlValidateList, Formula1:="=myNames"
.ShowError = False
.InCellDropdown = False
End With
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim x
If Target.Address(0, 0) <> "B2" Then Exit Sub
Application.EnableEvents = False
Range("B1,F1,H1,B4,F4,C5,C6,C7,C8,C9,B10,C10,B11,D11,G11" & _
",B12,D12,B13,B14,E14,B15,B16,B17,D17,F17,H17,J17,L17").ClearContents
On Error Resume Next
Me.Pictures.Delete
On Error GoTo 0
x = Application.Match(Target.Value, Sheets("データ").Columns(1), 0)
If IsNumeric(x) Then
myDataTransfer (x)
Else
If ItsMe Then
If vbYes = MsgBox(.Value & vbLf & "を追加しますか？", vbYesNo + vbQestion) Then
Sheets("データ").Range("a" & Rows.Count).End(xlUp)(2).Value = Target.Value
myUpdate = True
Else
Target.ClearContents
End If
End If
End If
Application.EnableEvents = True
End Sub
Private Sub Worksheet_Deactivate()
Dim myAdd, i As Long, x
If myUpdate Then
x = Application.Match(Me.Range("b2").Value, Sheets("データ").Columns(1), 0)
If IsNumeric(x) Then
myAdd = "B1,F1,H1,B4,F4,C5,C6,C7,C8,C9,B10,C10,B11,D11,G11" & _
",B12,D12,B13,B14,E14,B15,B16,B17,D17,F17,H17,J17,L17"
myAdd = Split(myAdd, ",")
With Sheets("データ")
For i = 0 To UBound(myAdd)
.Cells(x, i + 2).Value = Me.Range(myAdd(i)).Value
Next
End With
End If
myUpdate = False
End If
End Sub
Function myDataTransfer(ByVal rowNum)
Dim myAdd, i As Long, myFile As String
myAdd = "B1,F1,H1,B4,F4,C5,C6,C7,C8,C9,B10,C10,B11,D11,G11" & _
",B12,D12,B13,B14,E14,B15,B16,B17,D17,F17,H17,J17,L17"
myAdd = Split(myAdd, ",")
With Sheets("詳細")
For i = 0 To UBound(myAdd)
.Range(myAdd(i)).Value = Sheets("データ").Cells(rowNum, i + 2).Value
Next
On Error Resume Next
.Pictures.Delete
On Error GoTo 0
myFile = Dir(ThisWorkbook.Path & "\" & Sheets("データ").Cells(rowNum, "AD").Value)
If myFile = Sheets("データ").Cells(rowNum, "AD").Value Then
.Pictures.Insert (ThisWorkbook.Path & "\" & myFile)
Set myPic = .Pictures(.Pictures.Count)
myPic.Left = .Columns("G").Left
myPic.Top = .Rows(2).Top
myPic.Height = 120
myPic.Width = 90
End If
End With
End Function
>If vbYes = MsgBox(.Value & vbLf & "を追加しますか？", vbYesNo + vbQestion) Then .Value はTarget.Valueでは？ (通行人)
通行人さん、どうもです
If vbYes = MsgBox(.Value & vbLf & "を追加しますか？", vbYesNo + vbQestion) Then
を
If vbYes = MsgBox(Target.Value & vbLf & "を追加しますか？", vbYesNo + vbQestion) Then
に変更してください。
> (seiya)
通行人さん
ありがとうございました。
seiyaさん
上記変更しました。 エラーは出なくなりました。 ただ、ドロップダウンが出なくなりました。 データにない名前を書き込んでもエラーはでなくなりました。 リストにある名前を打ち込んだ場合は、きちんとデータが表示されます。
あと変わったところといえば、名前を消せば、全部のデータが消えるようになりました。
(syus)
.InCellDropDown = False
を
.InCellDropDown = True
に変更してください。
(seiya)
seiyaさん
ドロップダウン、出てくるようになりました。 エラーも出てません。 今のところの問題は解決されたようです！
(syus)
新規データは追加されましたか？ (seiya)
seiyaさん
申し訳ないです。 試してませんでした。
今試してみたところ、 もともとデータシートに打ち込んであるものしか詳細のドロップダウンには出てきませんね。 新しく追加でデータシートに打ち込んだデータをダブルクリックして、 一旦詳細シートに表示させても、ドロップダウンには表示されませんでした。
念のため、一旦エクセルを終了して、 もう一度開いてやってみましたが、 やはり新規に追加したデータは、詳細に反映されていないようです。
(syus)
詳細シートの change イベントコードを下記と差し替えてください。 リストに追加されるかどうか確かめてください。
Private Sub Worksheet_Change(ByVal Target As Range)
Dim x
If Target.Address(0, 0) <> "B2" Then Exit Sub
Application.EnableEvents = False
Range("B1,F1,H1,B4,F4,C5,C6,C7,C8,C9,B10,C10,B11,D11,G11" & _
",B12,D12,B13,B14,E14,B15,B16,B17,D17,F17,H17,J17,L17").ClearContents
On Error Resume Next
Me.Pictures.Delete
On Error GoTo 0
x = Application.Match(Target.Value, Sheets("データ").Columns(1), 0)
If IsNumeric(x) Then
myDataTransfer (x)
Else
If ItsMe Then
If vbYes = MsgBox(Target.Value & vbLf & "を追加しますか？", vbYesNo + vbQestion) Then
With Sheets("データ")
.Range("a" & Rows.Count).End(xlUp)(2).Value = Target.Value
.Range("a2", .Range("a" & Rows.Count).End(xlUp)).Name = "=myNames"
End With
DoEvents
myUpdate = True
Else
Target.ClearContents
End If
End If
End If
Application.EnableEvents = True
End Sub
(seiya)
seiyaさん
上記と差し替えましたが、追加されません。。 その他、特に変わったところ、異常が出たところはないようです。
チェックするポイントが他にもあれば、お願い致します。。
(syus)
リストに無い名前を入力したときにMsgBoxは出てきますか？ (seiya)
seiyaさん
出てこないですね。 本来ならば、追加しますか？が出るはずなんでしょうか？？
ちなみに、今のところ3人だけデータシートに打ち込んであるんですが、 （ダミーデータですが） 3人目の名前を消すと、詳細シートのドロップダウンの名前も消えます。 が、選択は出来ます。
ドロップダウンがこのようになります。
あああ うううを消去後 あああ いいい →→→→→→→→→ いいい ううう □□□
□は表示されませんが、空欄のまま、ドロップダウンが出るということです。
(syus)
一度閉じてから実行してください。 ItsMe がFalse になってしまっているのだと思います。 (seiya)
seiyaさん
一度閉じてからやりましたが、変わりません。 新たに入力したものも、ダブルクリックはできるようです。
ただ、やはりドロップダウンに追加されない＆メッセージボックスが出ない状況は変わっておりません。
(syus)
これで試してください。 MsgBoxが出ると思いますので、読んでください。
Private Sub Worksheet_Change(ByVal Target As Range)
Dim x
If Target.Address(0, 0) <> "B2" Then Exit Sub
Application.EnableEvents = False
Range("B1,F1,H1,B4,F4,C5,C6,C7,C8,C9,B10,C10,B11,D11,G11" & _
",B12,D12,B13,B14,E14,B15,B16,B17,D17,F17,H17,J17,L17").ClearContents
On Error Resume Next
Me.Pictures.Delete
On Error GoTo 0
MsgBox "ItsMe = " & ItsMe
x = Application.Match(Target.Value, Sheets("データ").Columns(1), 0)
MsgBox "Target.Value = " & Target.Value & vbLf & _
"x = " & x
If IsNumeric(x) Then
myDataTransfer (x)
Else
If ItsMe Then
If vbYes = MsgBox(Target.Value & vbLf & "を追加しますか？", vbYesNo + vbQestion) Then
With Sheets("データ")
.Range("a" & Rows.Count).End(xlUp)(2).Value = Target.Value
.Range("a2", .Range("a" & Rows.Count).End(xlUp)).Name = "=myNames"
End With
DoEvents
myUpdate = True
Else
Target.ClearContents
End If
End If
End If
Application.EnableEvents = True
End Sub
(seiya)
seiyaさん
ドロップダウンから名前を選択すると、メッセージボックスが出ました。 リストにない名前を記入しても、同様にでました。
ItsMe = と出たので、OKをクリックすると・・・ Target.Value = いいい（この時は"いいい"を選択してました。） x = 3 OKをクリックすると表示されました。
リストに無い名前を記入、もしくはB2をDeleteしようとすると・・・
ItsMe = と出た後、OKをクリックすると・・・ 実行時エラー13 型が一致しません。 と表示されます。そして
MsgBox "Target.Value = " & Target.Value & vbLf & _
"x = " & x
この部分が黄色くなり、選択されています。
(syus)
> ThisWorkbook モジュールへ > Excelのメニューバーの編集の左隣にあるエクセルアイコンを右クリックして-[コードの表示]
> Public ItsMe As Boolean
> Private Sub Workbook_Open()
> ItsMe = (InputBox("どなたですか？") = "syus")
> If ItsMe Then
> Sheets("データ").Visible = xlSheetVisible
> Else
> Sheets("データ").Visible = xlSheetVeryHidden
> End If
> End Sub
Public ItsMe As Boolean はありますよね？ (seiya)
seiyaさん
あります。 前文そのまま入ってます。 コードの場所も、ThisWorkbookで問題ありません。 詳細シートのコード、改めて現状をあげておきますね。
Private myUpdate As Boolean
Private Sub Worksheet_Activate()
With Range("b2").Validation
.Delete
.Add Type:=xlValidateList, Formula1:="=myNames"
.ShowError = False
.InCellDropdown = True
End With
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim x
If Target.Address(0, 0) <> "B2" Then Exit Sub
Application.EnableEvents = False
Range("B1,F1,H1,B4,F4,C5,C6,C7,C8,C9,B10,C10,B11,D11,G11" & _
",B12,D12,B13,B14,E14,B15,B16,B17,D17,F17,H17,J17,L17").ClearContents
On Error Resume Next
Me.Pictures.Delete
On Error GoTo 0
MsgBox "ItsMe = " & ItsMe
x = Application.Match(Target.Value, Sheets("データ").Columns(1), 0)
MsgBox "Target.Value = " & Target.Value & vbLf & _
"x = " & x
If IsNumeric(x) Then
myDataTransfer (x)
Else
If ItsMe Then
If vbYes = MsgBox(Target.Value & vbLf & "を追加しますか？", vbYesNo + vbQestion) Then
With Sheets("データ")
.Range("a" & Rows.Count).End(xlUp)(2).Value = Target.Value
.Range("a2", .Range("a" & Rows.Count).End(xlUp)).Name = "=myNames"
End With
DoEvents
myUpdate = True
Else
Target.ClearContents
End If
End If
End If
Application.EnableEvents = True
End Sub
Private Sub Worksheet_Deactivate()
Dim myAdd, i As Long, x
If myUpdate Then
x = Application.Match(Me.Range("b2").Value, Sheets("データ").Columns(1), 0)
If IsNumeric(x) Then
myAdd = "B1,F1,H1,B4,F4,C5,C6,C7,C8,C9,B10,C10,B11,D11,G11" & _
",B12,D12,B13,B14,E14,B15,B16,B17,D17,F17,H17,J17,L17"
myAdd = Split(myAdd, ",")
With Sheets("データ")
For i = 0 To UBound(myAdd)
.Cells(x, i + 2).Value = Me.Range(myAdd(i)).Value
Next
End With
End If
myUpdate = False
End If
End Sub
Function myDataTransfer(ByVal rowNum)
Dim myAdd, i As Long, myFile As String
myAdd = "B1,F1,H1,B4,F4,C5,C6,C7,C8,C9,B10,C10,B11,D11,G11" & _
",B12,D12,B13,B14,E14,B15,B16,B17,D17,F17,H17,J17,L17"
myAdd = Split(myAdd, ",")
With Sheets("詳細")
For i = 0 To UBound(myAdd)
.Range(myAdd(i)).Value = Sheets("データ").Cells(rowNum, i + 2).Value
Next
On Error Resume Next
.Pictures.Delete
On Error GoTo 0
myFile = Dir(ThisWorkbook.Path & "\" & Sheets("データ").Cells(rowNum, "AD").Value)
If myFile = Sheets("データ").Cells(rowNum, "AD").Value Then
.Pictures.Insert (ThisWorkbook.Path & "\" & myFile)
Set myPic = .Pictures(.Pictures.Count)
myPic.Left = .Columns("G").Left
myPic.Top = .Rows(2).Top
myPic.Height = 120
myPic.Width = 90
End If
End With
End Function
(syus)
Private Sub Worksheet_Activate()
With Range("b2").Validation
に一行挿入してください。
Private Sub Worksheet_Activate()
MsgBox ItsMe = True
With Range("b2").Validation
で実行してください。 (seiya)
seiyaさん
上記実行しました。 同様のエラーが出ます。 B2をDeleteしようとした場合も同じです。
(syus)
True または False のみのMsgBoxが表示されませんでしたか？ (seiya)
seiyaさん
詳細シートで上書きしていたので気付きませんでした汗。 詳細シートに移動すると、FalseのMsgBoxが表示されました。
(syus)
それが原因でしたね...
ThisWorkbook モジュールの Public ItsMe As Boolean をカットして [挿入] - [標準モジュール] で出てきた画面に貼り付けてください。 Saveして閉じまた開いてください。 (seiya)
seiyaさん
今度はTrueのMsgBoxになりました！！
B2セルのDeleteの際に出てくるMsgBoxはItsMe = Trueになりました。 ただ、その後エラーになるのは変わっていないようです。
(syus)
下記と差し替えてください。
Private Sub Worksheet_Change(ByVal Target As Range)
Dim x
If Target.Address(0, 0) <> "B2" Then Exit Sub
Application.EnableEvents = False
Range("B1,F1,H1,B4,F4,C5,C6,C7,C8,C9,B10,C10,B11,D11,G11" & _
",B12,D12,B13,B14,E14,B15,B16,B17,D17,F17,H17,J17,L17").ClearContents
On Error Resume Next
Me.Pictures.Delete
On Error GoTo 0
x = Application.Match(Target.Value, Sheets("データ").Columns(1), 0)
If IsNumeric(x) Then
myDataTransfer (x)
Else
If ItsMe Then
If vbYes = MsgBox(Target.Value & vbLf & "を追加しますか？", vbYesNo + vbQestion) Then
With Sheets("データ")
.Range("a" & Rows.Count).End(xlUp)(2).Value = Target.Value
.Range("a2", .Range("a" & Rows.Count).End(xlUp)).Name = "myNames"
End With
myUpdate = True
Else
Target.ClearContents
End If
End If
End If
Application.EnableEvents = True
End Sub
(seiya)
seiyaさん
上記差し替えました。 すると色々起こりました。。。
まずは、詳細シートに移動した際にTrueのMsgBoxが出ます。 （先ほどと変わらずです。） 名前選択の際には、MsgBoxは出なくなりました。 スムーズに表示されます。 ただ、相変わらず3件しかありません。
B2をDeleteすると・・・ を追加しますか？っていうMsgBoxが出ます。 はいをクリックすると、
実行時エラー1004 その名前は正しくありません。
とでて、
.Range("a2", .Range("a" & Rows.Count).End(xlUp)).Name = "=myNames"
の部分が黄色くなります。
リストに無い名前を打ちこんで、いいえをクリックすると
B2は空欄に戻ります。
こんなところが変更点だと思うんですが・・・ まだあるはず！とかあったら教えてください。。。
(syus)
1) Private Sub Worksheet_Activate()
MsgBox ItsMe = True '<- この行を削除
With Range("b2").Validation
2) .Range("a2", .Range("a" & Rows.Count).End(xlUp)).Name = "=myNames"
^^^^
="=myNames" の = を削除して ="myNames"にしてください。
(seiya)
seiyaさん
上記、1)、2)完了させました。
B2セルであああなど、既にあるものを選択 →詳細表示後Deleteする → を追加しますか？ Yes No のMsgBoxが表示される。 Yes→データシートにある追加されていないものが追加される。 No→何も追加されない。
詳細シートにてリストに無い名前を打ち込む。 →上記同様MsgBoxが表示される。 →Yes データシートにも追加される。 →No 追加されず、元の画面に戻る。
一旦詳細シートで打ちこんで追加したものは、 データシートで削除してもドロップダウンからはなくならないようですね。
あああ あああ いいい えええをデータシートにて削除 いいい ううう →→→→→→→→→→→→→→→→ううう えええ おおお おおお
という感じになるということです。 詳細のB2にてDeleteを押した後、 を追加しますか？のMsgBoxにて追加をクリックすると、 最新のデータシートの状況が反映されるという考え方で宜しいでしょうか？
(syus)
Else
If ItsMe Then
を
Else
If (Target.Value <> "") * ItsMe Then
に変更してください。 それと、データシートのA列のデータ範囲に空白は作らないようにしてください。 (seiya)
seiyaさん
>それと、データシートのA列のデータ範囲に空白は作らないようにしてください。 了解しました。更新の際、気をつけるようにします。 余談になってしまうのかもしれませんが、 A列に空白があると、マクロ上不具合が生じてしまうのでしょうか？
上記変更後、B2をDeleteしてもMsgBoxが表示されなくなりました！ かなりスムーズになった感がありますね☆
データシートからダブルクリックで詳細シートに飛んだ場合は、 ドロップダウンには増えないようですが、どうしたら増えますか？
(syus)
データシートの
Private Sub Worksheet_Deactivate()
Range("a2", Range("a" & Rows.Count).End(xlUp)).Name = "myNames"
End Sub
を
Private Sub Worksheet_Change(ByVal Target As Range)
If (Target.Column = 1) * (Target.Row >= 2) Then
Range("a2", Range("a" & Rows.Count).End(xlUp)).Name = "myNames"
End If
End Sub
に差し替えてください (seiya)
seiyaさん
解決しました！ 今のところ問題はなくなったと思います☆
(syus)
それでは、ファイルを開く際に syus 以外の文字を入力して、
1) データシートは表示されない 2) B2に新しい名前(リストにある名前以外)を入力しても、変化が無い
ことを確認してください。 (seiya)
seiyaさん
上記確認できました！！ ちょっとビックリしました（笑）
これで完全に編集可能なのは私オンリーになったってことですね！！
(syus)
仕様は
誰でも,
1) 詳細シートの閲覧
2) 詳細シートのB2を変更したとき、該当データがデータシートにあれば関連データを
所定のセルに表示、画像ファイルがあれば画像も表示
syusさんのみ
1) データシートの閲覧・編集 2) データシートのA列をダブルクリックして詳細シートに関連データを抽出 3) 詳細シートからデータシートの編集・新規登録
印刷も必要だと思いますので、それは明後日以降ということで。 明日はこちらに来ることができないと思います。 (seiya)
seiyaさん
今日もありがとうございました！ 上記、わかりました。 社内では、自分の名前を入れてファイルを開くようにしたいと思います。
20から週末にかけて、連休になってしまいますので、 週明けにまた宜しくお願い致します！！
・・・もしかして出勤することになるようであれば、 書き込みますので、是非お願いします☆
(syus)
Sheets("データ").Visible = xlSheetVisible した後
Sheets("データ").Visible = xlSheetVeryHiddenを行っていないみたいなので
>syusさんのみ
>1) データシートの閲覧・編集
はほかの人が、マクロを無効にして開くと・・・・
Sheets("データ").Visible = xlSheetVeryHiddenをWorkbook_BeforeClose
に追加したほうがよいかも。
(通行人)
> Sheets("データ").Visible = xlSheetVeryHiddenをWorkbook_BeforeClose
> に追加したほうがよいかも
PCを共有ということなのでデジタル署名で処理したほうが便利でしょう。
syusさん、上記は最後に説明します。
まず、現在までの仕様で（もうお気付きかも知れませんが) syusさんが詳細シートから データシートに移動する際に、データを更新します。 間違って、どこかのセルのデータを削除・変更してしまった場合でも、そのデータが データシートに転送される仕組みになっています。 確認してください。 今日は無理ですが、シート移動時に 1) 変更箇所を確認 2) 変更された場合、MsgBoxを出してその結果により、データシートを更新/非更新 のようなことを考えています。 (seiya)
詳細シートのコードを下記と差し替えて動作確認してください。
Private Sub Worksheet_Activate()
With Range("b2").Validation
.Delete
.Add Type:=xlValidateList, Formula1:="=myNames"
.ShowError = False
.InCellDropdown = True
End With
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim x
If Target.Address(0, 0) <> "B2" Then Exit Sub
Application.EnableEvents = False
Range("B1,F1,H1,B4,F4,C5,C6,C7,C8,C9,B10,C10,B11,D11,G11" & _
",B12,D12,B13,B14,E14,B15,B16,B17,D17,F17,H17,J17,L17").ClearContents
On Error Resume Next
Me.Pictures.Delete
On Error GoTo 0
x = Application.Match(Target.Value, Sheets("データ").Columns(1), 0)
If IsNumeric(x) Then
myDataTransfer (x)
Else
If ItsMe Then
If vbYes = MsgBox(Target.Value & vbLf & "を追加しますか？", vbYesNo + vbQestion) Then
With Sheets("データ")
.Range("a" & Rows.Count).End(xlUp)(2).Value = Target.Value
.Range("a2", .Range("a" & Rows.Count).End(xlUp)).Name = "myNames"
End With
DoEvents
myUpdate = True
Else
Target.ClearContents
End If
End If
End If
Application.EnableEvents = True
End Sub
Private Sub Worksheet_Deactivate()
Dim myAdd, i As Long, x, y
If myUpdate Then
x = Application.Match(Me.Range("b2").Value, Sheets("データ").Columns(1), 0)
If IsNumeric(x) Then
myAdd = "B1,F1,H1,B4,F4,C5,C6,C7,C8,C9,B10,C10,B11,D11,G11" & _
",B12,D12,B13,B14,E14,B15,B16,B17,D17,F17,H17,J17,L17"
y = HadChanged(myAdd) '<- 修正
If y <> "" Then
If vbYes = MsgBox("下記が変更されています。" & y & vbLf & "更新しますか？", _
vbYesNo + vbQuestion) Then
myAdd = Split(myAdd, ",")
With Sheets("データ")
For i = 0 To UBound(myAdd)
.Cells(x, i + 2).Value = Me.Range(myAdd(i)).Value
Next
End With
End If
End If
End If
myUpdate = False
End If
End Sub
Function myDataTransfer(ByVal rowNum)
Dim myAdd, i As Long, myFile As String
myAdd = "B1,F1,H1,B4,F4,C5,C6,C7,C8,C9,B10,C10,B11,D11,G11" & _
",B12,D12,B13,B14,E14,B15,B16,B17,D17,F17,H17,J17,L17"
myAdd = Split(myAdd, ",")
With Sheets("詳細")
For i = 0 To UBound(myAdd)
.Range(myAdd(i)).Value = Sheets("データ").Cells(rowNum, i + 2).Value
Next
On Error Resume Next
.Pictures.Delete
On Error GoTo 0
myFile = Dir(ThisWorkbook.Path & "\" & Sheets("データ").Cells(rowNum, "AD").Value)
If myFile = Sheets("データ").Cells(rowNum, "AD").Value Then
.Pictures.Insert (ThisWorkbook.Path & "\" & myFile)
Set myPic = .Pictures(.Pictures.Count)
myPic.Left = .Columns("G").Left
myPic.Top = .Rows(2).Top
myPic.Height = 120
myPic.Width = 90
End If
End With
End Function
Function HadChanged(ByVal myList As String) As String
Dim i As Long, msg As String, x
x = Split(myList, ",")
With Sheets("詳細")
For i = 0 To UBound(x)
If .Range(x(i)).Value <> _
Sheets("データ").Cells(x, i + 2) Then
HadChanged = HadChanged & vbLf & _
Sheets("データ").Cells(1, i + 2).Value
End If
Next
End With
End Function
(seiya)
seiyaさん
だいぶ間が空いてしまいましてすいません。 今日もなぜかなかなかここが開けず・・・
ということで、上記更新しました！
まず、データシートに移動する際に、 コンパイルエラー：SubまたはFunctionが定義されていません。 とでて、
Private Sub Worksheet_Deactivate()←この部分が黄色くなります。
Dim myAdd, i As Long, x, y
If myUpdate Then
x = Application.Match(Me.Range("b2").Value, Sheets("データ").Columns(1), 0)
If IsNumeric(x) Then
myAdd = "B1,F1,H1,B4,F4,C5,C6,C7,C8,C9,B10,C10,B11,D11,G11" & _
",B12,D12,B13,B14,E14,B15,B16,B17,D17,F17,H17,J17,L17"
y = HasChanged(myAdd)←この部分が選択されます。
さらに、詳細シートにてB2を削除した際に を追加しますか？ というMsgBoxが出るように戻ってしまった気がします。
詳細シート文頭の、Private myUpdate As Booleanは残しておいて良いんですよね？ それ以降の部分を上記と差し替えをしております。
(syus)
Typo です...
y = HadChanged(myAdd)
↑
(seiya)
seiyaさん
おはようございます！ 今日もよろしくお願いします＾＾
上記、修正後エラー改善されました！ シート移動においては問題がないようですが、 B2Deleteの際に を追加しますか？のMsgBoxが出てしまうのは、 上記のままです。
(syus)
If ItsMe Then を If (ItsMe) + (Targeet.Value <> "") Then に変更してください。 (seiya)
seiyaさん
上記修正しました。 同様にB2Deleteしようとすると・・・
実行時エラー424 オブジェクトが必要です。
と表示されてしまいます。 今修正したばかりの部分が黄色くなっております。。。
TargeetがTargetなのかな？と思い、直してみたんですが、 相変わらずMsgBoxが出てしまうようです。。。
(syus)
すみません...
If (ItsMe) * (Target.Value <> "") Then
^^^
にしてください。
(seiya)
seiyaさん
上記修正後、改善されました！ シート移動その他も問題ないように思います！！
(syus)
テストは十分にしてください。 次は Print です。
データシートの最終列の右隣の列(AE列?)を使用します。 AE1に列項目 印刷 とでもしてください。
CommandButton を設置する [表示] - [ツールバー] - [コントロールツールボックス] でコマンドボタンを詳細シートの適当な位置に配置してください。 配置したボタンをダブルクリックすると、表題が変更できますので 好きな名前にしてください。
ツールボックスの左上端に三角定規のようなアイコンがあると思いますので、 それをクリックして、デザインモードを解除します。 ボタンをダブルクリックしても表題が変更できないことを確認してください。
下記コードを詳細シートのモジュールに追加してください。
Private Sub CommandButton1_Click()
Dim rng As Range, r As Range
On Error Resume Next
Set rng = Range("ae2:ae" & Rows.Count).SpecialCells(2)
On Error GoTo 0
If rng Is Nothing Then Exit Sub
For Each r In rng
myDataTransfer(r.Row) ’←修正
Sheets("詳細").PrintOut '<- 修正
Next
End Sub
AE列の２行目以下の印刷したいデータ行に 1でもyでも？でも 何でも結構ですので 何らかの値を入力してください。（とりあえず 1行のみで試してください)
コマンドボタンを押すと、AE列に値のある行のデータが印刷されるはずですので確認してください。 (seiya) 修正 12:23
詳細シートのモジュールですが、 文頭に Public ItsMe As Booleanがあってもいいんでしょうか？ 開いた時点で既に書かれていたので、消さないものなのかと思いまして。。。
詳細シートのモジュールというのは、標準モジュールでいいんですよね？
データシートAE列の1行目（項目行）に印刷と記入し、詳細シートに移ろうとしたところ・・・
実行時エラー1004 アプリケーション定義またはオブジェクト定義のエラーです。
と表示され、詳細シートのコードの .Add Type:=xlValidateList, Formula1:="=myNames" の部分が黄色くなりました。
若干状況を把握しきれてない感があるので、 何かありましたら聞いて下さい汗。。。
なお、修正後を反映済みです。
(syus)
詳細シートのモジュールと標準モジュールは違います。 VBE画面のProject エクスプロラに
Sheet1(データ) Sheet2(詳細) ThisWorkbook Module1
のように表示されていると思います。 そのすべてがModule(モジュール)です。
Sheet2(詳細)をダブルクリックして開いたウィンドが Sheet2(詳細) モジュールの コードウィンドです。(Code Pane) そこに追加してください。
Module1 は現在のところ 1行だけのはずです。 (seiya)
seiyaさん
失礼いたしました。 指定の通りに、やり直しました。 ダブルクリックして開いたものの一番下に追加したんですが、 シートを移動しようとすると、
コンパイルエラー 名前が適切ではありません。CommandButton1_Click
と表示されます。 （）内に私が指定したボタン名を入れれば良いんでしょうか？？
(syus)
そのコードウィンドの上端に左右に分かれて２つのドロップダウンリストがあるはずです。 左側のドロップダウンリストの中に
CommandButton から始まるものはありませんか？
たぶん CommandButton1 の 1の部分が違っているのでしょう... (seiya)
seiyaさん
あったんですが、CommandButton1でした。 表示上同じように見えるんですが・・・
(syus)
そのモジュール内に、ほかに
Private Sub CommandButton1_Click()
End Sub
のようになっている部分がありませんか ? もしあったら削除してください。 (seiya)
seiyaさん
ありましたので、削除致しました。 シート移動でのエラーが出てしまいました。 詳細→データでは出ませんが、データ→詳細の移動で出てしまいます。 コマンドボタンを押しても印刷は始まりません。
コマンドボタンは〝印刷する"にしました。 13：37修正 (syus)
> シート移動でのエラーが出てしまいました。 いままで無かったのですよね？ 以前の状況に戻せますか？ (追加したコードを削除するという意味です) (seiya)
seiyaさん
戻したと思ったら、 名前をドロップダウンから選択すると、 MsgBoxが消えてしまいました汗。。。。
ちょっと追いきれていない可能性があるので、 一応詳細シートの現時点でのコードを全て記載しておきます。
その他原因としてありえそうな事がありましたら、 是非教えていただきたく思います。
Private myUpdate As Boolean
Private Sub Worksheet_Activate()
With Range("b2").Validation
.Delete
.Add Type:=xlValidateList, Formula1:="=myNames"
.ShowError = False
.InCellDropdown = True
End With
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim x
If Target.Address(0, 0) <> "B2" Then Exit Sub
Application.EnableEvents = False
Range("B1,F1,H1,B4,F4,C5,C6,C7,C8,C9,B10,C10,B11,D11,G11" & _
",B12,D12,B13,B14,E14,B15,B16,B17,D17,F17,H17,J17,L17").ClearContents
On Error Resume Next
Me.Pictures.Delete
On Error GoTo 0
x = Application.Match(Target.Value, Sheets("データ").Columns(1), 0)
If IsNumeric(x) Then
myDataTransfer (x)
Else
If (ItsMe) * (Target.Value <> "") Then
If vbYes = MsgBox(Target.Value & vbLf & "を追加しますか？", vbYesNo + vbQestion) Then
With Sheets("データ")
.Range("a" & Rows.Count).End(xlUp)(2).Value = Target.Value
.Range("a2", .Range("a" & Rows.Count).End(xlUp)).Name = "myNames"
End With
DoEvents
myUpdate = True
Else
Target.ClearContents
End If
End If
End If
Application.EnableEvents = True
End Sub
Private Sub Worksheet_Deactivate()
Dim myAdd, i As Long, x, y
If myUpdate Then
x = Application.Match(Me.Range("b2").Value, Sheets("データ").Columns(1), 0)
If IsNumeric(x) Then
myAdd = "B1,F1,H1,B4,F4,C5,C6,C7,C8,C9,B10,C10,B11,D11,G11" & _
",B12,D12,B13,B14,E14,B15,B16,B17,D17,F17,H17,J17,L17"
y = HadChanged(myAdd)
If y <> "" Then
If vbYes = MsgBox("下記が変更されています。" & y & vbLf & "更新しますか？", _
vbYesNo + vbQuestion) Then
myAdd = Split(myAdd, ",")
With Sheets("データ")
For i = 0 To UBound(myAdd)
.Cells(x, i + 2).Value = Me.Range(myAdd(i)).Value
Next
End With
End If
End If
End If
myUpdate = False
End If
End Sub
Function myDataTransfer(ByVal rowNum)
Dim myAdd, i As Long, myFile As String
myAdd = "B1,F1,H1,B4,F4,C5,C6,C7,C8,C9,B10,C10,B11,D11,G11" & _
",B12,D12,B13,B14,E14,B15,B16,B17,D17,F17,H17,J17,L17"
myAdd = Split(myAdd, ",")
With Sheets("詳細")
For i = 0 To UBound(myAdd)
.Range(myAdd(i)).Value = Sheets("データ").Cells(rowNum, i + 2).Value
Next
On Error Resume Next
.Pictures.Delete
On Error GoTo 0
myFile = Dir(ThisWorkbook.Path & "\" & Sheets("データ").Cells(rowNum, "AD").Value)
If myFile = Sheets("データ").Cells(rowNum, "AD").Value Then
.Pictures.Insert (ThisWorkbook.Path & "\" & myFile)
Set myPic = .Pictures(.Pictures.Count)
myPic.Left = .Columns("G").Left
myPic.Top = .Rows(2).Top
myPic.Height = 120
myPic.Width = 90
End If
End With
End Function
Function HadChanged(ByVal myList As String) As String
Dim i As Long, msg As String, x
x = Split(myList, ",")
With Sheets("詳細")
For i = 0 To UBound(x)
If .Range(x(i)).Value <> _
Sheets("データ").Cells(x, i + 2) Then
HadChanged = HadChanged & vbLf & _
Sheets("データ").Cells(1, i + 2).Value
End If
Next
End With
End Function
Private Sub CommandButton1_Click()
Dim rng As Range, r As Range
On Error Resume Next
Set rng = Range("ae2:ae" & Rows.Count).SpecialCells(2)
On Error GoTo 0
If rng Is Nothing Then Exit Sub
For Each r In rng
myDataTransfer (r.Row) '
Sheets("データ").PrintOut
Next
End Sub
修正 16:04
(syus)
昨日は突発的な外出があり、返信できませんでした。
.Add Type:=xlValidateList, Formula1:="=myNames"
は
.Add Type:=xlValidateList, Formula1:="myNames"
です。
(seiya)
seiyaさん
お疲れ様です。 本日もよろしくお願い致します。
上記、修正しました。 プルダウンにmyNamesしかでてこなくなってしまいました汗。。。 データシートからダブルクリックすれば、詳細シートに表示はされるんですが、 プルダウンには出てきません。
(syus)
詳細シートのコードは[印刷]以前のままになっていますか？ (seiya)
seiyaさん
一応、上記に記載したとおりのコードです。 印刷以前のままということは、上記から
Private Sub CommandButton1_Click()
Dim rng As Range, r As Range
On Error Resume Next
Set rng = Range("ae2:ae" & Rows.Count).SpecialCells(2)
On Error GoTo 0
If rng Is Nothing Then Exit Sub
For Each r In rng
myDataTransfer (r.Row) '
Sheets("データ").PrintOut
Next
End Sub
の部分を除けばいいはずですよね？ そのように修正してみたんですが、状況が変わりません。
(syus)
あっと、詳細シートではなくデータシートのコードです。 (seiya)
seiyaさん
データシートのコードは久しくいじってないと思うのですが・・・ 念のため、記載します。 どこか変えてしまってますかね汗。。。
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim x As Long, i As Long, myAdd, myPic As Object, myFile As String
If (Target.Column <> 1) + (Target.Row = 1) + (Target.Value = "") Then Exit Sub
Application.EnableEvents = False
Cancel = True
x = Target.Row
myAdd = "B2,B1,F1,H1,B4,F4,C5,C6,C7,C8,C9,B10,C10,B11,D11,G11" & _
",B12,D12,B13,B14,E14,B15,B16,B17,D17,F17,H17,J17,L17"
myAdd = Split(myAdd, ",")
With Sheets("詳細")
.Select
On Error Resume Next
.Pictures.Delete
On Error GoTo 0
For i = 0 To UBound(myAdd)
.Range(myAdd(i)).Value = Me.Cells(x, i + 1).Value
Next
myFile = Dir(ThisWorkbook.Path & "\" & Me.Cells(x, "AD").Value)
If myFile = Me.Cells(x, "AD").Value Then
.Pictures.Insert (ThisWorkbook.Path & "\" & myFile)
Set myPic = .Pictures(.Pictures.Count)
myPic.Left = .Columns("G").Left
myPic.Top = .Rows(2).Top
myPic.Height = 120
myPic.Width = 90
End If
End With
Application.EnableEvents = True
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If (Target.Column = 1) * (Target.Row >= 2) Then
Range("a2", Range("a" & Rows.Count).End(xlUp)).Name = "myNames"
End If
End Sub
(syus)
すみません勘違いしていました... > .Add Type:=xlValidateList, Formula1:="=myNames" >は > .Add Type:=xlValidateList, Formula1:="myNames" >です。 これは間違いですので = を付けた形に戻してください。
> データシートのコードは久しくいじってないと思うのですが・・・ 納得です...私が混乱させてしまいました。
印刷に関しての >> 下記コードを詳細シートのモジュールに追加してください。 は データシートのモジュールに の間違いです。 (seiya)
seiyaさん
いえいえ！ 大丈夫ですよ＾＾
=myNamesに戻したところ、詳細シートのデータ表示は問題なくなりました。
データシートのモジュールに追加するのは、
Private Sub CommandButton1_Click()
Dim rng As Range, r As Range
On Error Resume Next
Set rng = Range("ae2:ae" & Rows.Count).SpecialCells(2)
On Error GoTo 0
If rng Is Nothing Then Exit Sub
For Each r In rng
myDataTransfer (r.Row) '
Sheets("データ").PrintOut
Next
End Sub
の部分で大丈夫でしょうか？ 念のためにテストをしてみたら、SubまたはFunctionが定義されていません。 と出てきたもので・・・。 ちなみに、今は詳細シートには印刷ボタンはまだ作っていない状態になっております。
(syus)
詳細シートの
Function myDataTransfer(ByVal rowNum)
Dim myAdd, i As Long, myFile As String
myAdd = "B1,F1,H1,B4,F4,C5,C6,C7,C8,C9,B10,C10,B11,D11,G11" & _
",B12,D12,B13,B14,E14,B15,B16,B17,D17,F17,H17,J17,L17"
myAdd = Split(myAdd, ",")
With Sheets("詳細")
For i = 0 To UBound(myAdd)
.Range(myAdd(i)).Value = Sheets("データ").Cells(rowNum, i + 2).Value
Next
On Error Resume Next
.Pictures.Delete
On Error GoTo 0
myFile = Dir(ThisWorkbook.Path & "\" & Sheets("データ").Cells(rowNum, "AD").Value)
If myFile = Sheets("データ").Cells(rowNum, "AD").Value Then
.Pictures.Insert (ThisWorkbook.Path & "\" & myFile)
Set myPic = .Pictures(.Pictures.Count)
myPic.Left = .Columns("G").Left
myPic.Top = .Rows(2).Top
myPic.Height = 120
myPic.Width = 90
End If
End With
End Function
を 既にある Module1(現時点で一行のみのモジュール）へ移行してください。
(seiya)
seiyaさん
上記、完了しました。 ところで・・・現時点では何を確認すればよいのでしょうか？ 一応、シート移動、ダブルクリック、詳細シートのB2セルの削除あたりの、 問題になりがちなところはチェックしてみましたが、 以上は無いと思われます。
(syus)
データシートに CommandButton1 は配置されていますか？ 配置されていない場合は、既に示した手順に従って配置してください。
データシートのデータ範囲のAE列の適当な行になにか値を入力して CommandButton をクリックしてみてください。 (seiya)
seiyaさん
配置しました。 そしてAEに1と入力し、ボタンを押したところ・・・ 印刷されました！！ ただ、今のPCにドライバが入っていなかったようで汗。。。 これってデータシートが印刷されてるんですか？ PC移って試してみますが、印刷はできるようになったみたいですね＾＾
(syus)
値の入った行のデータが詳細シートに転送され、印刷されるはずです。 (seiya)
seiyaさん
印刷、試してみたんですが・・・ データシートの方が印刷されちゃいました。。。
(syus)
データシートの CommandButton1_Click() の
Sheets("データ").PrintOut
を
Sheets("詳細").PrintOut
に変更してください。
(seiya)
seiyaさん
無事に印刷されました！！ ・・・と思ったら、氏名が表示されないですね。。 その他は画像までしっかり出てると思います。
(syus)
同じく
Private Sub CommandButton1_Click()
の
If rng Is Nothing Then Exit Sub
For Each r In rng
myDataTransfer (r.Row) '
Sheets("データ").PrintOut
Next
End Sub
を
If rng Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each r In rng
myDataTransfer (r.Row) '
Sheets("データ").PrintOut
Next
Application.EnableEvents = True
End Sub
にしてください
(seiya)
seiyaさん
上記修正後、再度印刷ボタンにて印刷しました。 やはり氏名だけが表示されないですね。 ちなみに・・・
For Each r In rng
myDataTransfer (r.Row) '
Sheets("データ").PrintOut
↑
ここは"詳細"でいいんですよね？？
(syus)
いけね、またやってしまいました。 そのとおりです。
下記と差し替えてください。
Private Sub CommandButton1_Click()
Dim rng As Range, r As Range
On Error Resume Next
Set rng = Range("ae2:ae" & Rows.Count).SpecialCells(2)
On Error GoTo 0
If rng Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each r In rng
Sheets("詳細").Range("b2").Value = Me.Range("a" & r.Row).Value
myDataTransfer (r.Row)
Sheets("詳細").PrintOut
Next
Application.EnableEvents = True
End Sub
(seiya)
seiyaさん
差し替えました。 印刷、うまくいきました！！
(syus)
印刷は AE列に値が入力された行を印刷しますので、 印刷したら、AE列を無入力状態に戻しておいた方が よいと思いますが、これは自動ではしないようにします。
残しておくことで、印刷済みデータの表示もかねるかもしれませんので、 その辺はご自由に...
最後に、デジタル署名に付いて。
ですが、今のように印刷する際には他のPCで開くことになるのですか？ (seiya)
seiyaさん
AE列に入力する文字は何でもいいんでしょうか？ それと、複数のデータをまとめて印刷することも可能なのでしょうか？
印刷・・・は本来の自分のPCでできるようにはしようと思っているのですが、 他のPCでアウトする可能性も正直否めないです。
ちなみにデジタル署名というのは・・・？
(syus)
> AE列に入力する文字は何でもいいんでしょうか？ 値さえ入力されてれば、何でもいいです。
> それと、複数のデータをまとめて印刷することも可能なのでしょうか？ そのはずです。
> 他のPCでアウトする可能性も正直否めないです。 特定の1, 2台でのファイルの共有なら有効ですが、不特定多数のPCで使用する場合 デジタル署名は全く意味を持たなくなります。
> ちなみにデジタル署名というのは・・・？ SelfCert.exe で検索してください。
ちなみに、デジタル署名の登録設定をしたPCで指定したマクロ付きファイルを開くとき 警告なく、マクロを有効にして開けます。 これができないと、警告が出た段階でマクロを無効にされると不都合が生じることが あります。 もともとエクセルはセキューリテイを強固にして使用するような使い方をあまり考慮 していませんので、その辺は十分承知しておいてください。 (seiya)
seiyaさん
なるほど・・・。 アウトするPCを2台に絞るようにしますね。
ちなみに、今はファイル自体にもパスワードが掛けてあるのですが、 デジタル署名設定にあたって、それは外した方がいいんですよね？
(syus)
その辺は デジタル署名 SelfCert.exe あたりでヒットしたサイトに詳しく乗っていると思いますので まずは検索してください。 (seiya)
seiyaさん
検索してみましたが、どうもつけない方がいいような気がします。 現在通り、ブック自体にパスワードをかけておくので、現時点では事足りるかと。
もしものとき、 デジタル署名の作成自体はサイトを参考にすればできそうかな・・・ と思ったんですが、何か特別な処理が必要とかあるんでしょうか？？
(syus)
その辺は実際に使用して不都合が生じた場合に考慮してください。
特別の意味がわかりませんが、手順に従って設定するだけです。
とりあえず、 ThisWorkbook モジュールに
Priate Sub Workbook_BeforeClose()
Sheets("データ").Visible = xlSheetVeryHidden
Me.Protect "ここにパスワードを記入"
End Sub
ここにパスワードを記入 の部分を実際のパスワードに変更して追加しておいてください。 (seiya)
seiyaさん
上記、指定の場所に追加したんですが、 コンパイルエラー プロシージャの宣言がイベントまたはプロシージャの定義と一致していません。 と出てしまいます。
現状のThisWorkbookのモジュールはこのようになっております。
Private Sub Workbook_Open()
ItsMe = (InputBox("どなたですか？") = "syus")
If ItsMe Then
Sheets("データ").Visible = xlSheetVisible
Else
Sheets("データ").Visible = xlSheetVeryHidden
End If
End Sub
Private Sub Workbook_BeforeClose()
Sheets("データ").Visible = xlSheetVeryHidden
Me.Protect "syus"
End Sub
(syus)
Private Sub Workbook_BeforeClose(Cancel As Boolean)
^^^^^^^^^^^^^^^^^
が抜けていました。
(seiya)
seiyaさん
上記追加しました。 閉じるときは普通に閉じられたんですが・・・ 開くときにどなたですか？と聞かれるところで、 syusと打ってOKしたら・・・
実行時エラー1004 WorksheetクラスのVisibleプロパティを設定できません。
と出て、Sheets("データ").Visible = xlSheetVisibleの部分が黄色くなってます。
閉じようとすると、同じエラーが出ました・・・。
(syus)
Private Sub Workbook_Open()
Me.Unprotect "syus"
ItsMe = (InputBox("どなたですか？") = "syus")
If ItsMe Then
Sheets("データ").Visible = xlSheetVisible
Else
Sheets("データ").Visible = xlSheetVeryHidden
End If
End Sub
にしてみてください
(seiya)
seiyaさん
無事に開けました。 syusと入力して開いた後・・・
×を押して閉じようとすると、 上書き保存してあっても保存しますか？と聞かれます。 そしてそのMsgBoxが出るタイミングで、データシートが見えなくなってます。 画面下部のシート移動の部分が見えなくなるって事です。
(syus)
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
If ItsMe Then
Sheets("データ").Visible = xlSheetVeryHidden
Me.Protect "syus"
Else
Cancel = True
End If
End Sub
にしてみてください。
syus さんのみ保存可能になるはずです。
(seiya)
seiyaさん
もともとのBeforeCloseのところを、 上記頂いたBeforeSaveに変えるって認識でよいですか？？
それとも単純にThisWorkbookのモジュールに加えるってことでしょうか？
(syus)
Workbook_BeforeSave... . . .
End Sub
と差し替えてください。 (seiya)
seiyaさん
差し替えたんですが、違いがわかりません汗。。。
syusと入力して開いた場合→データ・詳細シート両方見れる状態。 閉じるタイミングで保存しますか？と聞かれる Ctrl+Zによる上書き保存が出来ない状態。 閉じる際に保存しますか？→はい、にしても開きなおすと、 差し替える前の状態にコードが戻ってしまっています。
以下が現状のコードなんですが・・・
Private Sub Workbook_Open()
Me.Unprotect "syus"
ItsMe = (InputBox("どなたですか？") = "syus")
If ItsMe Then
Sheets("データ").Visible = xlSheetVisible
Else
Sheets("データ").Visible = xlSheetVeryHidden
End If
End Sub
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
If ItsMe Then
Sheets("データ").Visible = xlSheetVeryHidden
Me.Protect "syus"
Else
Cancel = True
End If
End Sub
どこかおかしいところありますか？？ 17:07更新
(syus)
> 閉じる際に保存しますか？→はい、にしても開きなおすと、 > 差し替える前の状態にコードが戻ってしまっています。
Private Sub Workbook_Open()
Me.Unprotect "syus"
ItsMe = (InputBox("どなたですか？") = "syus")
If ItsMe Then
Sheets("データ").Visible = xlSheetVisible
Else
Sheets("データ").Visible = xlSheetVeryHidden
End If
End Sub
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
If ItsMe Then
Sheets("データ").Visible = xlSheetVeryHidden
Me.Protect "syus"
Else
Cancel = True
End If
End Sub
の状態で、Excel画面に戻らずにVBE画面で保存してください。 (seiya)
作業途中で一旦保存することはないのでしょうか？ (通行人)
seiyaさん
上記にさしかえて、VBE画面で上書き保存してるんですが、 やっぱり開きなおすと元に戻ってしまっておりますです。はい。
閉じるときに聞かれる保存しますか？は、いいえにしないといけないんですか？？
(syus)
1)
Private Sub Workbook_Open()
.
.
End Sub
のどこでもよいですので、クリック
2) F8を押して、コードを End Sub を抜けるまでF8を押して実行
3)
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
If ItsMe Then
Sheets("データ").Visible = xlSheetVeryHidden
Me.Protect "syus"
Else
Cancel = True
End If
End Sub
のどこかをクリックして、F8を押す。
F8を数回押して、
Sheets("データ").Visible = xlSheetVeryHidden
の行を実行するか確認してください。
(seiya)
seiyaさん
2)までは順調にいったんですが・・・ その後、BeforeSave以下にて、F8が押しても反応しません。
正常に機能してないって事でしょうか？
(syus)
そうですか... ItsuMe がVBEを開いた時点で初期化(False)になっているのでうまくSaveできないのでしょう。
今日はここで落ちますので...
ためしに
1) 下記に変更
Private Sub Workbook_Open()
Me.Unprotect "syus"
ItsMe <> (InputBox("どなたですか？") = "syus")
If Not ItsMe Then
Sheets("データ").Visible = xlSheetVisible
Else
Sheets("データ").Visible = xlSheetVeryHidden
End If
End Sub
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
If Not ItsMe Then
Sheets("データ").Visible = xlSheetVeryHidden
Me.Protect "syus"
Else
Cancel = True
End If
End Sub
2) 全モジュールの全コード中の If ItsMe Then を If Not ItsMe Then
に変更して見てください。 (seiya)
seiyaさん
ItsMe <> (InputBox("どなたですか？") = "syus")
↑
この部分って=ではないですか？
頂いたコードだと、上記の文が赤くなって、構文エラーが出てしまいます。
2)についてですが、 その他のモジュールにはIf ItsMe Thenが存在しないような気がするのですが・・・汗。
今日は落ちということなので、うっとうしいかもしれませんが、 現状コードをモジュールごとに載せておきます。 また明日もよろしくお願い致します！！
[標準モジュール]
Public ItsMe As Boolean
Function myDataTransfer(ByVal rowNum)
Dim myAdd, i As Long, myFile As String
myAdd = "B1,F1,H1,B4,F4,C5,C6,C7,C8,C9,B10,C10,B11,D11,G11" & _
",B12,D12,B13,B14,E14,B15,B16,B17,D17,F17,H17,J17,L17"
myAdd = Split(myAdd, ",")
With Sheets("詳細")
For i = 0 To UBound(myAdd)
.Range(myAdd(i)).Value = Sheets("データ").Cells(rowNum, i + 2).Value
Next
On Error Resume Next
.Pictures.Delete
On Error GoTo 0
myFile = Dir(ThisWorkbook.Path & "\" & Sheets("データ").Cells(rowNum, "AD").Value)
If myFile = Sheets("データ").Cells(rowNum, "AD").Value Then
.Pictures.Insert (ThisWorkbook.Path & "\" & myFile)
Set myPic = .Pictures(.Pictures.Count)
myPic.Left = .Columns("G").Left
myPic.Top = .Rows(2).Top
myPic.Height = 120
myPic.Width = 90
End If
End With
End Function
[ThisWorkbook]
Private Sub Workbook_Open()
Me.Unprotect "syus"
ItsMe = (InputBox("どなたですか？") = "syus")
If Not ItsMe Then
Sheets("データ").Visible = xlSheetVisible
Else
Sheets("データ").Visible = xlSheetVeryHidden
End If
End Sub
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
If Not ItsMe Then
Sheets("データ").Visible = xlSheetVeryHidden
Me.Protect "syus"
Else
Cancel = True
End If
End Sub
[コードシート]
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim x As Long, i As Long, myAdd, myPic As Object, myFile As String
If (Target.Column <> 1) + (Target.Row = 1) + (Target.Value = "") Then Exit Sub
Application.EnableEvents = False
Cancel = True
x = Target.Row
myAdd = "B2,B1,F1,H1,B4,F4,C5,C6,C7,C8,C9,B10,C10,B11,D11,G11" & _
",B12,D12,B13,B14,E14,B15,B16,B17,D17,F17,H17,J17,L17"
myAdd = Split(myAdd, ",")
With Sheets("詳細")
.Select
On Error Resume Next
.Pictures.Delete
On Error GoTo 0
For i = 0 To UBound(myAdd)
.Range(myAdd(i)).Value = Me.Cells(x, i + 1).Value
Next
myFile = Dir(ThisWorkbook.Path & "\" & Me.Cells(x, "AD").Value)
If myFile = Me.Cells(x, "AD").Value Then
.Pictures.Insert (ThisWorkbook.Path & "\" & myFile)
Set myPic = .Pictures(.Pictures.Count)
myPic.Left = .Columns("G").Left
myPic.Top = .Rows(2).Top
myPic.Height = 120
myPic.Width = 90
End If
End With
Application.EnableEvents = True
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If (Target.Column = 1) * (Target.Row >= 2) Then
Range("a2", Range("a" & Rows.Count).End(xlUp)).Name = "myNames"
End If
End Sub
Private Sub CommandButton1_Click()
Dim rng As Range, r As Range
On Error Resume Next
Set rng = Range("ae2:ae" & Rows.Count).SpecialCells(2)
On Error GoTo 0
If rng Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each r In rng
Sheets("詳細").Range("b2").Value = Me.Range("a" & r.Row).Value
myDataTransfer (r.Row)
Sheets("詳細").PrintOut
Next
Application.EnableEvents = True
End Sub
[詳細シート]
Private myUpdate As Boolean
Private Sub Worksheet_Activate()
With Range("b2").Validation
.Delete
.Add Type:=xlValidateList, Formula1:="=myNames"
.ShowError = False
.InCellDropdown = True
End With
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim x
If Target.Address(0, 0) <> "B2" Then Exit Sub
Application.EnableEvents = False
Range("B1,F1,H1,B4,F4,C5,C6,C7,C8,C9,B10,C10,B11,D11,G11" & _
",B12,D12,B13,B14,E14,B15,B16,B17,D17,F17,H17,J17,L17").ClearContents
On Error Resume Next
Me.Pictures.Delete
On Error GoTo 0
x = Application.Match(Target.Value, Sheets("データ").Columns(1), 0)
If IsNumeric(x) Then
myDataTransfer (x)
Else
If (ItsMe) * (Target.Value <> "") Then
If vbYes = MsgBox(Target.Value & vbLf & "を追加しますか？", vbYesNo + vbQestion) Then
With Sheets("データ")
.Range("a" & Rows.Count).End(xlUp)(2).Value = Target.Value
.Range("a2", .Range("a" & Rows.Count).End(xlUp)).Name = "myNames"
End With
DoEvents
myUpdate = True
Else
Target.ClearContents
End If
End If
End If
Application.EnableEvents = True
End Sub
Private Sub Worksheet_Deactivate()
Dim myAdd, i As Long, x, y
If myUpdate Then
x = Application.Match(Me.Range("b2").Value, Sheets("データ").Columns(1), 0)
If IsNumeric(x) Then
myAdd = "B1,F1,H1,B4,F4,C5,C6,C7,C8,C9,B10,C10,B11,D11,G11" & _
",B12,D12,B13,B14,E14,B15,B16,B17,D17,F17,H17,J17,L17"
y = HadChanged(myAdd)
If y <> "" Then
If vbYes = MsgBox("下記が変更されています。" & y & vbLf & "更新しますか？", _
vbYesNo + vbQuestion) Then
myAdd = Split(myAdd, ",")
With Sheets("データ")
For i = 0 To UBound(myAdd)
.Cells(x, i + 2).Value = Me.Range(myAdd(i)).Value
Next
End With
End If
End If
End If
myUpdate = False
End If
End Sub
Function HadChanged(ByVal myList As String) As String
Dim i As Long, msg As String, x
x = Split(myList, ",")
With Sheets("詳細")
For i = 0 To UBound(x)
If .Range(x(i)).Value <> _
Sheets("データ").Cells(x, i + 2) Then
HadChanged = HadChanged & vbLf & _
Sheets("データ").Cells(1, i + 2).Value
End If
Next
End With
End Function
以上です。長々しくて本当にすいません。 毎日のようにありがとうございます。
(syus)
1)
ItsMe = Not (InputBox("どなたですか？") = "syus")
にしてください。
2) 詳細シートの Private Sub Worksheet_Change(ByVal Target As Range)
If (ItsMe) * (Target.Value <> "") Then
を
If (Not ItsMe) * (Target.Value <> "") Then
に変更してください。
(seiya)
seiyaさん
落ちギリギリまでありがたい限りです＾＾ 上記差し替えました。
すると・・・ 実行時エラー1004 WorksheetクラスのVisibleプロパティを設定できません。 と表示され、
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
If Not ItsMe Then
Sheets("データ").Visible = xlSheetVeryHidden←この部分が黄色くなっております。
Me.Protect "syus"
Else
Cancel = True
End If
End Sub
今日は私も落ちます。 また明日！よろしくお願い致します！！
(syus)
> Sheets("データ").Visible = xlSheetVeryHidden←この部分が黄色くなっております。
Private Sub Workbook_Open()から「途中でエラー発生なし」で一連の流れでやらなければ×
BOOKがProtectされている状態でSheets("データ").Visible = xlSheetVeryHiddenは×
(通行人)
syusさん
BeforeSave のコードを削除して
イミディエイトウィンドに
Sheets("データ").Visible = xlSheetVeryHidden
として、Enter してください。
これで保存して下さい。 (seiya)
seiyaさん
保存できました。 途中で上書き保存も出来るようになったようです。
ただ・・・ どなたですか？のところでsyusと入力しても、 データシートが表示されなくなってしまったのですが・・・？
(syus)
Private Sub Workbook_Open()
Me.Unprotect "syus"
ItsMe = Not (InputBox("どなたですか？") = "syus")
If Not ItsMe Then
Sheets("データ").Visible = xlSheetVisible
End If
End Sub
にしてください。
(seiya)
seiyaさん
上記に修正しました。 syusで見られるようになったのはいいのですが、 syus以外の名前でも見えてしまうようです。
(syus)
syusさん
Private Sub Workbook_Open()
Me.Unprotect "syus"
ItsMe = Not (InputBox("どなたですか？") = "syus")
If Not ItsMe Then
Sheets("データ").Visible = xlSheetVisible
Else
Sheets("データ").Visible = xlSheetVeryHidden
End If
End Sub
にしてもだめですか？
(seiya)
seiyaさん
OKです！ 滞りなくなりました。 ちなみに・・・なんですが、詳細シートのほうで印刷出来るようにしたいんですが・・・ というのも、私以外が閲覧＆プリントアウトのみをする場合に、 その方が便利かないうのがありまして。 まぁ、普通に印刷すればいいっちゃあいいんですが汗。。。
私が今日は出てしまう都合で非常に申し訳ないんですが、 もし宜しければ教えていただければと思います。
(syus)
> まぁ、普通に印刷すればいいっちゃあいいんですが汗。。。
多分一枚のみの印刷になるのでしょうから、それでよいと思いますが？ (seiya)
seiyaさん
あ、なるほど！！ 大量に一気に印刷するためのボタンと考えればよかったのですね！！
有効な使い道をわかっていなかったようで、 お恥ずかしい限りです汗。。
長いこと本当にありがとうございました！ おそらくもう大丈夫かと思ってるんですが、 まだ使う上での注意などあれば、ご教授ください。
(syus)
ファイルを開く際にマクロを有効にする は絶対条件です。
使用してみて、不都合が出たら投稿してください。 (seiya)
seiyaさん
マクロ有効、わかりました。 気を付けて使うようにします。
ではでは、本当に長い期間ありがとうございました。
また何かありましたら、宜しくお願い致します＾＾
(syus)
seiyaさん
早速なんですが・・・ データシートに1行追加したいんですが、 どのように修正すればよいでしょうか？ データ転送部分はなんとなくわかったのですが、 写真の転送セルの変え方がわからなくて汗。。。
具体的には、データシートのR行とS行の間に1行"口座番号"という項目を追加したいんです。 転送先セルはG12です。
これをやると、印刷ボタンとかも変更しなきゃいけなくなるんですか？？
早速で申し訳ないですが、宜しくお願いします！！
(syus)
列 ですよね？
1) 全ての myAdd の D12,B13 の間に G12
D12,G12,B13
後はわかりますか？
1) 画像ファイルの列を AD -> AE 2) CommandButton click 時のループ列が AE -> AF
このような簡単なメンテは今後少なからず生じてくると思いますので、自分でできるようにして下さい。 (seiya)
seiyaさん
まさしく・・・後半二つがわからなかったんです。 最初の1)はわかったんですが。
myFile = Dir(ThisWorkbook.Path & "\" & Me.Cells(x, "AD").Value)
If myFile = Me.Cells(x, "AD").Value Then
.Pictures.Insert (ThisWorkbook.Path & "\" & myFile)
Set myPic = .Pictures(.Pictures.Count)
の部分のAD→AEに。
Private Sub CommandButton1_Click()
Dim rng As Range, r As Range
On Error Resume Next
Set rng = Range("ae2:ae" & Rows.Count).SpecialCells(2)
のae2:aeの部分をaf2:afで大丈夫ですか？？
(syus)
よいと思います。 ファイルのコピーを作成してコピーファイルの方のコードを変更して試してください。 (seiya)
seiyaさん
ありがとうございます！ 早速で申し訳ありませんでした汗。。。
(syus)
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.