|
▼t−k さん:
こんばんは
>素人なのでわかりやすく教えてください
わかりやすくはないと思いますが・・・
必要なら、主要なところにコメントをつけますけど、とりあえず。
アップされたコードは全く読んでいません。
提示されたレイアウトだけを見て処理しています。
Sheet2に転記できなかったSheet1のセルに色づけするとともに、
Sheet2にしか存在しなかったものについてもSHeet2側のセルに色づけしています。
Sub Sample()
Dim fSh As Worksheet
Dim tSh As Worksheet
Dim fDic As Object
Dim tDic As Object
Dim c As Range
Dim dt As Double
Dim com As String
Dim dKey As Variant
Application.ScreenUpdating = False
Set fDic = CreateObject("Scripting.Dictionary")
Set tDic = CreateObject("Scripting.Dictionary")
Set fSh = Sheets("Sheet1")
Set tSh = Sheets("Sheet2")
fSh.Cells.Interior.ColorIndex = xlNone
tSh.Cells.Interior.ColorIndex = xlNone
With fSh.Range("A1").CurrentRegion
For Each c In .Offset(1, 2).Resize(.Rows.Count - 1, .Columns.Count - 2)
dt = fSh.Cells(1, c.Column).Value2
com = fSh.Cells(c.Row, "A").Value
fDic(com & dt) = VBA.Array(c.Value, c.Address(External:=True))
Next
End With
With tSh.Range("A1").CurrentRegion
For Each c In .Offset(1, 2).Resize(.Rows.Count - 1, .Columns.Count - 2)
dt = tSh.Cells(1, c.Column).Value2
com = tSh.Cells(c.Row, "A").Value
tDic(com & dt) = VBA.Array(c.Value, c.Address(External:=True))
Next
End With
'Sheet1からSheet2への転記
For Each dKey In fDic
If tDic.exists(dKey) Then
Range(tDic(dKey)(1)).Value = Range(fDic(dKey)(1)).Value
Else
Range(fDic(dKey)(1)).Interior.ColorIndex = 3
End If
Next
'Sheet2 にしか存在しない項目の色つけ
For Each dKey In tDic
If Not fDic.exists(dKey) Then Range(tDic(dKey)(1)).Interior.ColorIndex = 3
Next
tSh.Activate
Application.ScreenUpdating = True
MsgBox "転記完了"
End Sub
|
|