こちらで色々と教えていただき、大分解決してまいりましたが
まったくの素人でマクロがわからないので是非、教えてください。
また、教えてばかりで申し訳ないので自分で少しマクロを勉強してみたいのですが
どこか良いサイトまたは本など、ありましたら教えてください。
エクセルで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
こちらで色々と教えていただき、大分解決してまいりましたが
まったくの素人でマクロがわからないので是非、教えてください。
また、教えてばかりで申し訳ないので自分で少しマクロを勉強してみたいのですが
どこか良いサイトまたは本など、ありましたら教えてください。
エクセルで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
以前ここで質問させていただきました。
http://okwave.jp/qa3029622.html
上の内容のとおり教えていただきました。
マクロにさらにタイトルを追加したいのですが可能でしょうか？
ファイルAのタイトルは5行目から始まり8行目まであります。
ファイルBのタイトルは2行目から始まり6行目まであります。
★ファイルAのタイトルにファイルBのタイトルをつけ加えたい！
以下のソースに付け加えるとしたら、どこにどのように追加すればよいですか？
以上ですがよろしくお願いいたします。
Sub findJoin()
On Error GoTo err
Dim st1 As Worksheet
Dim st2 As Worksheet
Set st1 = ActiveSheet
Workbooks.Open ("870xtd.xls")
Set st2 = Workbooks("870xtd.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 R As Long
For R = 2 To st1MaxRow
Dim nmRng As Range
Set nmRng = st2.Range("AB2:AP" & st2Maxrow).Find(st1.Cells(R, "A").Value, LookIn:=xlValues)
If Not nmRng Is Nothing Then
'発見した。
st2.Range("A" & nmRng.Row & ":AP" & nmRng.Row).Copy Destination:=st1.Range("DQ" & R)
End If
Next
st1.Activate
Set st1 = Nothing
Set st2 = Nothing
Exit Sub
err:
MsgBox Error
End Sub
