ExcelのVBAで別ブックの２つのシートから条件が一致したデータを自動的に転記さるコードを、以前こ

ExcelのVBAで別ブックの２つのシートから条件が一致したデータを自動的に転記さるコードを、以前こちらで教えていただいたものですが、またまた、お力をお借りできれば幸いです。

ファイルの情報としては以下です。
book1(転記先)
book2(元データ)sheet1 sheet2

book1
A列 にはID番号
Ｂ列には名前
C列はフリガナ
D列には性別
E列には年齢

book2
sheet1.2ともに
A列 にはコース名
Ｂ列にはID番号
C列は名前
D列にはフリガナ
E列には年齢
Ｆ列には性別
が更に大きいくくりの参加コースごとにシート分けされてる状態です。
また、book2の２つのシートの並びは同じです。


book1内のマクロ実行でbook2のC列名前、
D列フリガナ、E列年齢、Ｆ列性別を同時にbook１の該当項目の欄に自動更新で転記させたいです。
条件としては「ID番号が一致した場合」です。
なお、book1のID番号がbook2にない場合はそのままbook1のC列は空白表示で出来たらと思ってます。

どうかよろしくお願いします。

No.2 ベストアンサー 回答者： tatsu99 回答日時： 2018/08/30 11:47

>更にbook2のリスト内にないIDの場合、直接入力で情報を、入れたりするのですが、教えていただいたものを実行すると、当たり前なのですが情報が、消えて空白に、なってしまいます、、、。

>そこを空白に、せず残しておく方法はありますか？

以下の箇所をコメントにしてください
----------------------------------------------------------------
sh.Cells(row, "B").Value = "" 'Book1のB列を空白設定
sh.Cells(row, "C").Value = "" 'Book1のC列を空白設定
sh.Cells(row, "D").Value = "" 'Book1のC列を空白設定
sh.Cells(row, "E").Value = "" 'Book1のC列を空白設定
---------------------------------------------------------------
コメントにするには先頭に'を付けます。そうすると以下のようになります。
' sh.Cells(row, "B").Value = "" 'Book1のB列を空白設定
' sh.Cells(row, "C").Value = "" 'Book1のC列を空白設定
' sh.Cells(row, "D").Value = "" 'Book1のC列を空白設定
' sh.Cells(row, "E").Value = "" 'Book1のC列を空白設定

この回答へのお礼

出来ました！本当にありがとうございます！色々、ネットや本などで調べてたのですが、なかなか別シートを扱うものが少なく困ってましたが無事解決出来ました。
2度も教えてくださり本当にありがとうございました！

お礼日時：2018/08/30 13:28

No.1 回答者： tatsu99 回答日時： 2018/08/29 23:59

前回回答者です。

前回のは使えませんので破棄してください。
以下のマクロを標準モジュールに登録してください。
Const SrcBook As String = "book2.xlsx" '元データのブック名
Const Folder As String = "d:\goo\excel" '元データを格納するフォルダ名
はあなたの環境に合わせて適切に設定して下さい。
前回はIDに対応する1つの項目のみの設定でしたが、今回は複数項目なので
IDに対応するBook2のシート名と行番号を記憶し、そのデータに基づき、Book1を設定します。
----------------------------------------------------
Option Explicit
Const SrcBook As String = "book2.xlsx" '元データのブック名
Const Folder As String = "d:\goo\excel" '元データを格納するフォルダ名
Public Sub 自動転記()
Dim dict As Object
Dim maxrow As Long
Dim row As Long
Dim key As Variant
Dim sh As Worksheet
Dim vals As Variant
Dim sname As String
Dim row2 As Long
Set dict = CreateObject("Scripting.Dictionary") ' 連想配列の定義
Workbooks.Open Filename:=Folder & "\" & SrcBook
Call GetIDs("sheet1", dict)
Call GetIDs("sheet2", dict)
ThisWorkbook.Activate
Set sh = Worksheets("sheet1") 'Book1のSheet1（以下Sheet1を使用）
maxrow = sh.Cells((Rows.Count), "A").End(xlUp).row 'Book1のA列最終行
For row = 2 To maxrow
key = sh.Cells(row, "A").Value 'Book1のA列（ID）
If dict.exists(key) = True Then
vals = Split(dict(key), "|") 'シート名(vals(0)と行番号(vals(1)を"|"で分割して取得する
sname = vals(0)
row2 = vals(1)
sh.Cells(row, "B").Value = Workbooks(SrcBook).Worksheets(sname).Cells(row2, "C").Value 'Book1のB列設定
sh.Cells(row, "C").Value = Workbooks(SrcBook).Worksheets(sname).Cells(row2, "D").Value 'Book1のC列設定
sh.Cells(row, "D").Value = Workbooks(SrcBook).Worksheets(sname).Cells(row2, "E").Value 'Book1のD列設定
sh.Cells(row, "E").Value = Workbooks(SrcBook).Worksheets(sname).Cells(row2, "F").Value 'Book1のE列設定
Else
sh.Cells(row, "B").Value = "" 'Book1のB列を空白設定
sh.Cells(row, "C").Value = "" 'Book1のC列を空白設定
sh.Cells(row, "D").Value = "" 'Book1のC列を空白設定
sh.Cells(row, "E").Value = "" 'Book1のC列を空白設定
End If
Next
Workbooks(SrcBook).Close
MsgBox ("完了")
End Sub

Private Sub GetIDs(ByVal sname As String, ByVal dict As Object)
Dim maxrow As Long
Dim row As Long
Dim key As Variant
Dim sh As Worksheet
Set sh = Worksheets(sname)
maxrow = sh.Cells((Rows.Count), "B").End(xlUp).row 'Book2のB列（ID）（Sheet1,Sheet2共通）
For row = 2 To maxrow
key = sh.Cells(row, "B").Value 'Book2のB列（ID）（Sheet1,Sheet2共通）
dict(key) = sname & "|" & row 'Book2のシート名と行番号を記憶する（"|"で区切る）
Next
End Sub

この回答へのお礼

前回、今回と2度も教え下さりありがとうございます！説明もつけていただき、とてもわかりやすく、助かりました！
無事、作成出来ました！
後、本当に厚かましいのですが、更にbook2のリスト内にないIDの場合、直接入力で情報を、入れたりするのですが、教えていただいたものを実行すると、当たり前なのですが情報が、消えて空白に、なってしまいます、、、。そこを空白に、せず残しておく方法はありますか？
もし、よければ教えていただきたいです。

お礼日時：2018/08/30 11:23