EXCEL VBAを教えてください。part2

質問

下記3つのファィルを結合し、新しいファイルを作らないといけないのですがどうしたら良いのかわかりません。親切な方ご教授ください。
●1つ目
1行目 日時　　　名前　　金額
2行目 20061201　 Aさん　100円
3行目 20061202 Aさん 200円
4行目 20061204　 Bさん　100円
（以下名前ごとに行が続きます。）
●2つ目
1行目 名前　　金額　　 日時
2行目　Aさん　 400円　　12月1日
3行目　Aさん　 500円　　12月2日
4行目　Aさん　1100円　　NULL　 ⇒名前ごとの合計欄です。
5行目　Bさん　 500円　　12月4日
6行目　Bさん　 600円　　12月5日
（以下名前ごとに行が続きます。）
●3つ目
1行目 名前 　金額上限
2行目　Aさん 5000円
3行目　Bさん 10000円
（以下それぞれの名前ごとに行が続きます。）

以上を下記1つの新しいファィルに仕上げたいのです。
1行目 名前　金額 日時　 　金額上限
2行目 Aさん 100円 20061201　5000円
3行目 Aさん 200円 20061202　5000円
4行目 Aさん 400円 12月1日 　5000円
5行目 Aさん 500円 12月2日 　5000円
6行目 NULL 1200円 NULL 5000円⇒2つ合計を計算
7行目 Bさん 100円 20061204 10000円
8行目 Bさん 500円 12月4日　10000円
9行目 Bさん 600円 12月5日　10000円
10行目NULL 1200円 NULL 10000円⇒2つ合計を計算
（以下名前ごとに行が続きます。）

回答No.1

Wendy02

こんにちは。

このご質問は、ちょっと厳しいものがありますね。シートならわかりますが、ファイル（ブック単位）ですと、なかなかすんなり書く人は少ないのではないでしょうか？もう、システム開発の部類に入ってしまいますから、あまり個々の事例でおつくりするというのは無理かもしれません。

ちょっと簡単なものを作ってみました。

※注意：

条件として、以下のブックのシートとマクロは、同じ場所にあるものとします。
これまでバラバラですと、かなりややこしいです。最初に、マクロにファイル名の設定が必要です。

●3つ目
1行目 名前 　金額上限
2行目　Aさん 5000円
3行目　Bさん 10000円
（現在では、検索に使用する名前に空白除去などの設定がされておりません。まったく同じものでなければなりません。）

また、現在の設定では、ブックは自動的に開きませんから、３つのファイルは全部開けておいてください。新規ブックは、保存されていませんので、Book? という名前しかありません。

また、Null というのは良く理解できていません。Null というのは、無効という意味で、英文会計では、「0（ゼロ）」という意味です。ですから、特に処理をされていません。
'----------------------------------------------------------------
'標準モジュール

Sub Consolidating()
'v.2614479.00
Dim NameList As Range
Dim i As Long
Dim j As Long
Dim k As Integer
Dim n As Integer
Dim r As Range
Dim Sh1 As Worksheet
Dim Sh2 As Worksheet
Dim Sh3 As Worksheet
Dim Sh4 As Worksheet
Dim Shs As Collection
Set Shs = New Collection

On Error GoTo ErrMsg
Set Sh1 = Workbooks("Test.xls").Worksheets("Sheet1")　'要設定
Set Sh2 = Workbooks("Test061.xls").Worksheets("Sheet1")　'要設定
Shs.Add Item:=Sh1
Shs.Add Item:=Sh2

Set Sh3 = ThisWorkbook.Worksheets("Sheet1")　'要設定
　With Workbooks.Add
　　Set Sh4 = .Worksheets(1)
　End With

With Sh3
Set NameList = .Range("A2", .Range("A65536").End(xlUp)).Resize(, 2)
End With

'個別コピー
For i = 1 To NameList.Rows.Count
For j = 1 To 2
With Shs(j)
　 .Range("A1").AutoFilter Field:=3 - j, Criteria1:=NameList.Cells(i, 1).Value
　 If .Range("A65536").End(xlUp).Row > 1 Then

　　With .Range("A2").Resize(.AutoFilter.Range.Rows.Count - 1, 3)

　　　For Each r In .Columns
　　　　If r.Cells(0).Value Like "*名前*" Then
　　　　　r.Copy Sh4.Range("A65536").End(xlUp).Offset(k)
　　　　ElseIf r.Cells(0).Value Like "*金額*" Then
　　　　　r.Copy Sh4.Range("B65536").End(xlUp).Offset(k)
　　　　ElseIf r.Cells(0).Value Like "*日時*" Then
　　　　　r.Copy Sh4.Range("C65536").End(xlUp).Offset(k)
　　　　　On Error Resume Next
　　　　　 n = r.SpecialCells(xlCellTypeVisible).Rows.Count
　　　　　On Error GoTo 0
　　　　　If n > 0 Then
　　　　　Sh4.Range("D65536").End(xlUp).Offset(k).Resize(n).Value = _
　　　　　NameList.Cells(i, 2).Value
　　　　　End If
　　　　End If
　　　Next r
　　End With
　 k = 1
　 End If
　End With
Next j
Next i

For j = 1 To 2
With Shs(j)
　.AutoFilterMode = False
End With
Next
Set Sh1 = Nothing: Set Sh2 = Nothing: Set Sh3 = Nothing: Set Sh4 = Nothing
Set NameList = Nothing
ErrMsg:
If Err.Number > 0 Then
　MsgBox Err.Number & " : " & Err.Description
End If
Set Shs = Nothing

End Sub

'----------------------------------------------------------------

お礼

大変ありがとうございました。
確かにシステム開発の部類に入ってしまいます。
ソースを元に一度チャレンジしてみます。