２つのものが一致時に転記するマクロ

質問

いつもお世話になります。

ここのサイトで
２つのブックでIDが一致したら
横にある文字を転記するというマクロがあるのですが
同じIDが続いても転記先のエクセルに全て転記したいと質問させて頂き
そのマクロを使わせて頂いたのですが

ＩＤと時間を一致したものを転記させなければいけなくなりました

Ａ列の時間とＢ列のＩＤを一致したときに
大元に転記させるのは、変数で2つの項目を設定して
確認させればいいのかと思っていましたが上手くいきません

更に、データ量が多いので
マクロを動かすたびに応答なしになるので
コードをfindから別なコードを変えたほうがよろしいのでしょうか？

下記にマクロのコードと構成と画像を記述させて頂きます
お手数ですがご教授して頂けないでしょうか？
恐縮ですがよろしくお願いいたします。

Sub 転記改造()
　　Dim w0 As Worksheet, w1 As Worksheet
　　Dim h As Range, Target As Range
Dim i As Range, Target1 As Range
　　Dim FirstAddress As String

　　Set w0 = Workbooks("IDデータ.xls").Worksheets(1)
　　Set w1 = Workbooks("ID管理票.xls").Worksheets(1)

　　For Each h In w0.Range("A2:A" & w0.Range("A65536").End(xlUp).Row)
For Each i In w0.Range("B2:B" & w0.Range("A65536").End(xlUp).Row)
　　　　If h.Offset(, 1).Value = "確認" Then
　　　　　　Set Target = w1.Range("D11:D60000").Find(what:=h.Value, LookIn:=xlValues, lookat:=xlWhole)
　　　　　　If Not Target Is Nothing Then
　　　　　　　　FirstAddress = Target.Address
　　　　　　　　Do
　　　　　　　　　　If Target.Offset(, -1).Value = "" Then
　　　　　　　　　　　　Target.Offset(, -1) = "確認"
　　　　　　　　　　　　Exit Do
　　　　　　　　　　Else
　　　　　　　　　　　　Set Target = w1.Range("D11:D60000").FindNext(Target)
　　　　　　　　　　End If
　　　　　　　　Loop While FirstAddress <> Target.Address
　　　　　　End If
　　　　End If
　　Next
　　next
End Sub

回答No.1

tom04 · ベストアンサー

こんばんは！
基本的に他人様がお考えのコードに手を付けるのは好みでないので、
新しくやってみました。

↓の画像のように左側が「IDデータ.xls」のSheet1で、右側が「ID管理票xls」のSheet1とします。

「ID管理票」ブックの標準モジュールに↓のコードをコピー＆ペーストしてマクロを実行してみてください。

Sub Sample1()
Dim i As Long, lastRow1 As Long, lastRow2 As Long
Dim c As Range, wS1 As Worksheet, wS2 As Worksheet
Application.ScreenUpdating = False
Set wS1 = Workbooks("IDデータ.xls").Worksheets(1)
wS1.Activate
lastRow1 = wS1.Cells(Rows.Count, "A").End(xlUp).Row
wS1.Range("A:A").Insert
Range(wS1.Cells(2, "A"), wS1.Cells(lastRow1, "A")).Formula = "=B2&""_""&C2"
With ThisWorkbook.Worksheets(1)
.Activate
lastRow2 = .Cells(Rows.Count, "A").End(xlUp).Row
.Range("A:A").Insert
.Range("A1") = "ダミー"
Range(.Cells(2, "A"), .Cells(lastRow2, "A")).Formula = "=B2&""_""&C2"
Worksheets.Add after:=Worksheets(Worksheets.Count)
Set wS2 = ThisWorkbook.Worksheets(Worksheets.Count)
.Range("A:A").AdvancedFilter Action:=xlFilterCopy, copytorange:=wS2.Range("A1"), unique:=True
On Error Resume Next '←念のため
For i = 2 To wS2.Cells(Rows.Count, "A").End(xlUp).Row
.Range("A1").AutoFilter field:=1, Criteria1:=wS2.Cells(i, "A")
Set c = wS1.Range("A:A").Find(what:=wS2.Cells(i, "A"), LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
Range(.Cells(2, "D"), .Cells(lastRow2, "D")).SpecialCells(xlCellTypeVisible) = "確認"
End If
Next i
.AutoFilterMode = False
.Range("A:A").Delete
wS1.Range("A:A").Delete
Application.DisplayAlerts = False
wS2.Delete
Application.DisplayAlerts = True
.Activate
End With
Application.ScreenUpdating = True
MsgBox "処理完了"
End Sub

※　最初の質問がどのような結果がお望みだったのかが判らないので
的外れならごめんなさいね。m(_ _)m

お礼

お忙しい中、拙い説明で
コードを記述して頂きありがとうございます。

コードを試させてもらった所、やりたいことは出来ています。
ありがとうございます。
ただ、記述して頂いて大変申し訳ないのですが
載せている画像と実際の配置が結構違う所があるので

実際のデータを試して再度連絡させて頂きます

忙しい中ありがとうございます！！！

補足

返答、遅くなり申し訳ありません
実際のデータのエクセルで試したところ、
確認の項目がＢ列に来てＩＤ番号が上書きされてました。

コード自体はテストデータの時は問題なかったので
私の構成の書き方が拙いため伝わらないのが原因だと
思います。申し訳ありません。

コードを記述して頂いた中
本当に申し訳ありません。
実際のデータの構成図を書かせて頂きます
色々と食い違ってる部分があって申し訳ありません。

転記先のＩＤ管理票.xls
このエクセルは別のマクロを組んでいて
メールと連動していてメール受信後、自動で
Ａ列　Ｂ列　Ｃ列に次から次へとデータがのってきます
このエクセルは原本のためマクロを更に追加したり
行を消したりふやしたりはできないです。

Ｄ列以降は空白です。
Ｅ列にＩＤデータ.xlsに記述した項目ごとのシートを確認して
文言を手作業で入力
文言は　「確認」　「払出」　「保留」　「取下」　「転記」　「再確認」

Ａ列の横は20000から始まっていますが過去のデータ3か月分乗っているので
データ量が行1から行20000以降続いています

列番号　　　Ａ列 B列 C列 D列 E列
20000 2014/11/19 18:13:11　19001236　　 新規　　　　　　　 確認
20001 2014/11/19 18:33:08　19001237　　 修正　　　　　　　 払出
20002 2014/11/19 18:33:06 19001237　　 修正　　　　　　　 払出
20003 2014/11/19 17:23:11 19001238　　 修正　　　　　　　 保留
20004 2014/11/19 17:23:11 19001239　　 修正　　　　　　　 取下
20005 2014/11/19 17:23:11 19001240　　 修正　　　　　　　 転記
20006 2014/11/19 17:23:11 19001241　　 修正　　　　　　　 再確認

・Ａ列にＩＤを受領した時間が記述
　時間帯はバラバラです。

・Ｂ列にＩＤ番号が記載
　同じ番号続いたりします。

・Ｃ列はＩＤの区分の新規.修正が入ります

・Ｄ列は空白

・Ｅ列に確認項目を入力します 現状　
　最初の時は空白で、ＩＤデータ.xlsのシートに時間とＩＤと区分を記述して
　ＩＤデータ.xlsのシートを確認して手作業で入力

　文言は　「確認」　「払出」　「保留」　「取下」　「転記」　「再確認」

転記元のＩＤデータ.xls

シートが転記先のＩＤ管理票.xlsの入力する文言
ＩＤ管理票.xlsのＤ列の文言ごとにシートが分かれています
「確認」　「払出」　「保留」　「取下」　「転記」　「再確認」の５つのシートで分かれている

　　　　確認のシート
列番号　　　 Ａ列　　　　　　　　B列 　C列　　
1　 2014/11/19 18:13:11　　　　 19001236　　 新規　

　　　　払出のシート
列番号　　　 Ａ列　　　　　　　　B列 　C列　　
1 　　 2014/11/19 18:33:08　　　　 19001237　　 修正　　　　　　
2　 　 　2014/11/19 18:33:06 19001237　　 修正

　　　保留のシート　　　　　　　　　　　
列番号　　　 Ａ列　　　　　　　　B列 　C列　
1 　　 2014/11/19 17:23:11 19001238　　 修正　　　　　　　

取下のシート
列番号　　　 Ａ列　　　　　　　　B列 　C列　
1 　　 2014/11/19 17:23:11 19001239　　 修正　

　　　　転記のシート
列番号　　　 Ａ列　　　　　　　　B列 　C列
1 　　 2014/11/19 17:23:11 19001240　　 修正　

　　　　再確認のシート
列番号　　　 Ａ列　　　　　　　　B列 　C列
1 　　2014/11/19 17:23:11 19001241　　 修正

やりたいことは
ＩＤデータ.xlsの方にマクロを組み込んで
ＩＤ管理票のＤ列に
時間とＩＤが一致したものを
文言（「確認」　「払出」　「保留」　「取下」　「転記」　「再確認」　の５つの項目）を転記

実際の構成データで書かせていただきましたが
伝わりにくい、構成図の画面等が必要であれば
再度、質問を挙げさせていただきます

忙しい中、コードまで記述して頂いた中、申し訳ありません。
確認して頂いてもよろしいでしょうか？
宜しくお願い致します

回答No.2

tom04

No.1です。
補足を読ませていただきました。

↓の画像のような配置でよろしいのでしょうか？

今回は「IDデータ.xls」の標準モジュールにしてみてください。
尚、コード内に若干のコメントを記載しています。

Sub Sample2()
Dim i As Long, k As Long, lastRow1 As Long, lastRow2 As Long
Dim wS1 As Worksheet, wS2 As Worksheet
Application.ScreenUpdating = False
Set wS2 = Workbooks("ID管理票.xls").Worksheets(1)
lastRow2 = wS2.Cells(Rows.Count, "A").End(xlUp).Row
'▼「ID管理表票ook」のシート1、C～E列データ消去
If lastRow2 > 1 Then
Range(wS2.Cells(2, "C"), wS2.Cells(lastRow2, "C")).ClearContents
Range(wS2.Cells(2, "E"), wS2.Cells(lastRow2, "E")).ClearContents
End If
'▼「ID管理票、シート1」のF列を作業用の列として使用
Range(wS2.Cells(2, "F"), wS2.Cells(lastRow2, "F")).Formula = "=A2&""_""&B2"
'▼「IDデータBook」のシート1～最終シートまでループ
With ThisWorkbook
For k = 1 To .Worksheets.Count
Set wS1 = .Worksheets(k)
lastRow1 = wS1.Cells(Rows.Count, "A").End(xlUp).Row
'▼「IDデータBook」の各SheetのD列を作業用の列として使用
If lastRow1 > 1 Then
Range(wS1.Cells(2, "D"), wS1.Cells(lastRow1, "D")).Formula = "=A2&""_""&B2"
'▼「ID管理票Book、シート1」の作業列（F列）でフィルタを掛ける
'非表示になっている行のC列に「IDデータBook」の○番目シートのC列データを、E列にはシート名を！
For i = 2 To lastRow1 '★
wS2.Rows(1).AutoFilter field:=6, Criteria1:=wS1.Cells(i, "D")
If wS2.Cells(Rows.Count, "A").End(xlUp).Row > 1 Then
Range(wS2.Cells(2, "C"), wS2.Cells(lastRow2, "C")). _
SpecialCells(xlCellTypeVisible) = wS1.Cells(i, "C")
Range(wS2.Cells(2, "E"), wS2.Cells(lastRow2, "E")). _
SpecialCells(xlCellTypeVisible) = wS1.Name
End If
Next i
'▼「IDデータBook、各Sheet」の作業列を消去
wS1.Range("D:D").ClearContents
End If
Next k
End With
'▼オートフィルタを解除、「ID管理票、シート1の作業列（F列）を消去
wS2.AutoFilterMode = False
wS2.Range("F:F").ClearContents
Application.ScreenUpdating = True
End Sub

※　「ID管理票Bookのシート1」のF列と「IDデータBook」の各SheetのD列を作業用の列として使用していますので、
ID管理票Book、シート1はF列以降使用していない。
IDデータBook、各SheetはD列以降使用していない。
という前提です。

※　画像では各Sheetの1行目が項目行でデータは2行目以降にあるとしています。
尚、「IDデータBook」の各Sheetのデータが1行目からある場合は
コード内の「★」マークの行の
＞For i = 2 To lastRow1
を
＞For i = 1 To lastRow1
に変更してください。

こんな感じではどうでしょうか？m(_ _)m

お礼

tom04様
無事、やりたいことは出来ました。
ありがとうございます！！

find～nextのコードをこのサイトで
教えて頂いて動かしたのですが
データ量が多すぎて応答なしになっていました。
データ量が多い時の動かすのにフィルタ機能を使うことや
シート名を変数で一気に指定すること

色々とマクロの使い方の勉強になります。

ベストアンサーにに選ばさせて頂きます。
構成の書き方が拙い中、
後程、構成を乗せたとき、文字ズレや段ずれがあって
非常に見にくい状態の中、ご対応頂き
誠にありがとうございます！！