パート3★Excelで２つのファイルデータをマクロで自動的にひとつにする方法

質問

こちらで色々と教えていただき、大分解決してまいりましたが
まったくの素人でマクロがわからないので是非、教えてください。
また、教えてばかりで申し訳ないので自分で少しマクロを勉強してみたいのですが
どこか良いサイトまたは本など、ありましたら教えてください。

エクセルで2つのファイルを自動的にひとつにしました。

ファイルA、ファイルBに【名前が同じ】データがあるとします。
　1.ファイルAはA列に【名前】があります。
　2.ファイルBはAB列～AP列までのどこかにファイルAと同じ【名前】があります。
　3.ファイルAの【名前】を参照して、ファイルBの【名前】がある行のデータを丸ごと
　　ファイルAの【名前】が一致する行へコピーします。
　4.また、ファイルBに同じ【名前】が2つ以上登録されていた場合
　　ファイルAへコピーするときに、上書きされてしまう恐れがあるので
　　ファイルAへコピーされる時に行を追加、すぐ下の行にその内容を追加したい。
　5.ファイルAの名前が必ずしもファイルBにあるとは限りません。
　　ファイルAの名前がファイルBにない場合は無視し(空白になる)、次の行へ移動し検索コピーの作業を続けたい。
　　ファイルBの名前がファイルAにない場合にファイルBの名前の行を丸ごとファイルAの最後の行に追加したい。
　　ただし、そのファイルBは【太郎】という文字を含むもの(例・山本太郎や山田太郎など)のみにしたい。

ちなみにファイルAにはA～DP列までデータが入っていますので、それ以降にファイルBのデータの行を自動コピーされるようにします。

データが1000件以上あります。

私が今使用しているマクロを下記に記述します。
わかる方いましたら教えてください。

説明がわかりにくくて申し訳ないです。

以上よろしくお願いします。

Sub sample1()

On Error GoTo err

Dim st1 As Worksheet
Dim st2 As Worksheet

Set st1 = ActiveSheet

Workbooks.Open ("sample1.xls")
Set st2 = Workbooks("sample1.xls").Sheets(1)

Dim st1maxRow As Long
Dim st2maxRow As Long

st1maxRow = st1.Cells(st1.Rows.Count, "A").End(xlUp).Row
st2maxRow = st2.Cells(st2.Rows.Count, "AB").End(xlUp).Row

Dim InsertRow As Long
Dim R As Long
R = 2
While R <= st1maxRow

Dim nmRng As Range
If st1.Cells(R, "A").Value <> Empty Then
Set nmRng = st2.Range("AB2:AP" & st2maxRow).Find(st1.Cells(R, "A").Value, LookIn:=xlValues)

If Not nmRng Is Nothing Then
'発見した。
InsertRow = findLoop(st1, st2, R, st2maxRow, nmRng)
st1maxRow = st1maxRow + InsertRow - 1 '終了行数を補正
R = R + InsertRow - 1 '検索位置補正
Else
Set nmRng = st2.Range("AB2:AP" & st2maxRow).Find("太郎", LookIn:=xlValues)

If Not nmRng Is Nothing Then
'★ 太郎を発見
InsertRow = findLoop(st1, st2, R, st2maxRow, nmRng)
st1maxRow = st1maxRow + InsertRow - 1 '終了行数を補正
R = R + InsertRow - 1 '検索位置補正
End If

End If
End If

R = R + 1 '繰り返し回数を更新

Wend

st1.Activate

Set st1 = Nothing
Set st2 = Nothing

Exit Sub

err:
MsgBox Error
End Sub
'★ 同じ名前が有る場合行を下に追加してコピー
Function findLoop(ByVal st1 As Worksheet _
, ByVal st2 As Worksheet _
, ByVal R As Long _
, ByVal st2maxRow As Long _
, ByVal nmRng As Range) As Long

On Error GoTo err

findLoop = 0 '追加行数を初期化

Dim stopAddr As String
stopAddr = nmRng.Address 'Findの終了判定アドレス

Do
findLoop = findLoop + 1 '発見回数をカウント

If findLoop > 1 Then
'複数発見した場合に行を追加
st1.Rows(R + 1).Insert Shift:=xlShiftDown
R = R + 1 'ファイルAの格納位置は追加行へ
End If

'発見した行をCopy
st2.Range("A" & nmRng.Row & ":AP" & nmRng.Row).Copy Destination:=st1.Range("DQ" & R)

'次を検索
Set nmRng = st2.Range("AB2:AP" & st2maxRow).FindNext(nmRng)

If nmRng Is Nothing Then
'発見できないので終了
Exit Do
End If

Loop While nmRng.Address <> stopAddr

Exit Function
err:
MsgBox Error

End Function

回答No.1

x0000x · ベストアンサー

こんいちは。

マクロについての学習は、色々な書籍があります。
また、インタネットで検索すると色々なTIPSも公開されているので
個別機能のヒントを見つけ、EXCELのヘルプや書籍で少しずつ理解していけば良いと思います。
EXCELの「新しいマクロの記録」を解析することでもコード内容と操作がイメージし易いかもしれません。
頑張ってください。

やりたい処理はこんな感じで如何でしょうか？

ファイルAの名前がファイルBで発見できた場合、ファイルBの「AZ列」に”●”印を付けて識別しました。
この列が不都合であれば、★印の箇所を任意の未使用列に代えてください。
処理終了時のメッセージを追加しました。

Option Explicit
Sub sample1()
On Error GoTo err

Dim st1 As Worksheet
Dim st2 As Worksheet

Set st1 = ActiveSheet

Workbooks.Open ("sample1.xls")
Set st2 = Workbooks("sample1.xls").Sheets(1)

Dim st1maxRow As Long
Dim st2maxRow As Long

st1maxRow = st1.Cells(st1.Rows.Count, "A").End(xlUp).Row
st2maxRow = st2.Cells(st2.Rows.Count, "AB").End(xlUp).Row

'ファイルAで発見した印をクリア
st2.Range("AZ2:AZ" & st2maxRow).Clear '★

Dim nmRng As Range
Dim InsertRow As Long
Dim R As Long
R = 2
While R <= st1maxRow

If st1.Cells(R, "A").Value <> Empty Then
Set nmRng = st2.Range("AB2:AP" & st2maxRow).Find(st1.Cells(R, "A").Value, LookIn:=xlValues)

If Not nmRng Is Nothing Then
'発見した。
InsertRow = findLoop(st1, st2, R, st2maxRow, nmRng)
st1maxRow = st1maxRow + InsertRow - 1 '終了行数を補正
R = R + InsertRow - 1 '検索位置補正
End If
End If

R = R + 1 '繰り返し回数を更新

Wend

'ファイルAで検索できなかったファイルBの【太郎】を検索
R = st1maxRow
Set nmRng = st2.Range("AB2:AP" & st2maxRow).Find("太郎", LookIn:=xlValues)

If Not nmRng Is Nothing Then
'太郎を発見
Dim stopAddr As String
stopAddr = nmRng.Address 'Findの終了判定アドレス

Do
If st2.Range("AZ" & nmRng.Row).Value <> "●" Then '★
'ファイルAの検索外で太郎を発見　COPYする
R = R + 1 'ファイルAの格納行位置更新
st2.Rows(nmRng.Row).Copy Destination:=st1.Rows(R)
End If

'次を検索
Set nmRng = st2.Range("AB2:AP" & st2maxRow).FindNext(nmRng)

If nmRng Is Nothing Then
'発見できないので終了
Exit Do
End If

Loop While nmRng.Address <> stopAddr
End If

'印をクリア
st2.Range("AZ2:AZ" & st2maxRow).Clear '★

st1.Activate

Set st1 = Nothing
Set st2 = Nothing

MsgBox "終了しました！"

Exit Sub

err:
MsgBox Error
End Sub

'★ 同じ名前が有る場合行を下に追加してコピー
Function findLoop(ByVal st1 As Worksheet _
, ByVal st2 As Worksheet _
, ByVal R As Long _
, ByVal st2maxRow As Long _
, ByVal nmRng As Range) As Long

On Error GoTo err

findLoop = 0 '追加行数を初期化

Dim stopAddr As String
stopAddr = nmRng.Address 'Findの終了判定アドレス

Do
findLoop = findLoop + 1 '発見回数をカウント

If findLoop > 1 Then
'複数発見した場合に行を追加
st1.Rows(R + 1).Insert Shift:=xlShiftDown
R = R + 1 'ファイルAの格納位置は追加行へ
End If

'発見した行をCopy
st2.Range("A" & nmRng.Row & ":AP" & nmRng.Row).Copy Destination:=st1.Range("DQ" & R)
st2.Range("AZ" & nmRng.Row).Value = "●" '★

'次を検索
Set nmRng = st2.Range("AB2:AP" & st2maxRow).FindNext(nmRng)

If nmRng Is Nothing Then
'発見できないので終了
Exit Do
End If

Loop While nmRng.Address <> stopAddr

Exit Function
err:
MsgBox Error

End Function

お礼

いつもお世話になっております。
回答ありがとうございます。出力がおかげさまでうまくいきました。
またマクロのこともがんばって勉強したいとおもいます。

自分が書いた5番目の説明の仕方が悪く、思ったような出力になりませんでした。

【ファイルBの名前がファイルAにない場合にファイルBの名前の行を丸ごとファイルAの最後の行に追加したい。】

こちらは正しくは
【ファイルBの名前がファイルAにない場合にファイルBの名前の行を丸ごとファイルAのDQ移行に追加したい】
が正しい説明でした。
毎度、お手数おかけいたします。お暇なときに回答いただけると大変たすかります。

回答No.2

x0000x

こんにちは。

>こちらは正しくは
>【ファイルBの名前がファイルAにない場合にファイルBの名前の行を丸ごとファイルAのDQ移行に追加したい】
>が正しい説明でした。

「ファイルBの名前の行を丸ごと」は、EXCEL操作で言うところの「行選択＆Copy」として解釈しました。
行で選択したデータは行で貼り付け可能ですが、特定のセル以降にCOPYできません。
よって、ファイルBのA：AP列をファイルAのDQ列以降にCOPYするコードに変えるなら、以下のコードとなります。

変更前：st2.Rows(nmRng.Row).Copy Destination:=st1.Rows(R)
変更後：st2.Range("A" & nmRng.Row & ":AP" & nmRng.Row).Copy Destination:=st1.Range("DQ" & R)

※ファイルBの列位置は適当に変更ください。

お礼

いつもご回答ありがとうございます。
無事に解決いたしました。本当に色々とおせわになりました。
また何かありましたらよろしくお願いいたします。