| |
▼ブーチー さん：
バグあればご容赦。
Sub Sample()
Dim dic1 As Object
Dim dic2 As Object
Dim dic3 As Object
Dim c As Range
Dim dKey As Variant
Dim x As Long
Dim cnt1 As Long
Dim cnt2 As Long
Application.ScreenUpdating = False
Set dic1 = CreateObject("Scripting.Dictionary")
Set dic2 = CreateObject("Scripting.Dictionary")
Set dic3 = CreateObject("Scripting.Dictionary")
With Sheets("Sheet1") '元シート
For Each c In .Range("A2", .Range("A" & .Rows.Count).End(xlUp))
dKey = c.Value & vbTab & c.Offset(, 1).Value
If Not dic1.exists(dKey) Then _
Set dic1(dKey) = CreateObject("Scripting.Dictionary")
dic1(dKey)(dic1(dKey).Count) = c.Resize(, 4).Value
dic3(dKey) = True
Next
For Each c In .Range("F2", .Range("F" & .Rows.Count).End(xlUp))
dKey = c.Value & vbTab & c.Offset(, 1).Value
If Not dic2.exists(dKey) Then _
Set dic2(dKey) = CreateObject("Scripting.Dictionary")
dic2(dKey)(dic2(dKey).Count) = c.Resize(, 6).Value
dic3(dKey) = True
Next
End With
With Sheets("Sheet2") '転記シート
.Cells.ClearContents
.Rows(1).Value = Sheets("Sheet1").Rows(1).Value 'タイトル行
x = 2 'データ転記開始行
For Each dKey In dic3
cnt1 = 0
cnt2 = 0
If dic1.exists(dKey) Then
.Range("A" & x).Resize(dic1(dKey).Count, 4).Value = _
WorksheetFunction.Transpose( _
WorksheetFunction.Transpose(dic1(dKey).items))
cnt1 = dic1(dKey).Count
End If
If dic2.exists(dKey) Then
.Range("F" & x).Resize(dic2(dKey).Count, 6).Value = _
WorksheetFunction.Transpose( _
WorksheetFunction.Transpose(dic2(dKey).items))
cnt2 = dic2(dKey).Count
End If
x = x + WorksheetFunction.Max(cnt1, cnt2)
Next
.Select
End With
Application.ScreenUpdating = True
MsgBox "転記終了しました"
End Sub
|
|
UO3
- 12/12/1(土) 1:12 -
