| |
速度を期待することは出来ませが、ロジックとしては
Sub Test_Calc2()
Dim Sh As Worksheet, Sh2 As Worksheet
Dim MyR As Range, C As Range
Dim Ck As Variant
Set Sh = Worksheets("Sheet1")
Set Sh2 = Worksheets("Sheet2")
On Error GoTo ELine
Set MyR = Sh.Range("B:B").SpecialCells(2)
On Error GoTo 0
For Each C In Sh2.Range("A1", Sh2.Range("A65536").End(xlUp))
Ck = Application.Match(C.Value, Sh.Range("A:A"), 0)
If Not IsError(Ck) Then
If Not Intersect(Sh.Cells(Ck, 2), MyR) Is Nothing Then
C.Offset(, 1).Value = Sh.Cells(Ck, 2).Value
End If
End If
Next
ELine:
Set MyR = Nothing: Set Sh = Nothing: Set Sh2 = Nothing
End Sub
あるいは、検索元と検索先を逆にすることが可能なら
Sub Test_Calc3()
Dim Sh As Worksheet, Sh2 As Worksheet
Dim MyR As Range, C As Range
Dim Ck As Variant
Set Sh = Worksheets("Sheet1")
Set Sh2 = Worksheets("Sheet2")
On Error GoTo ELine
Set MyR = Sh.Range("B:B").SpecialCells(2)
On Error GoTo 0
For Each C In MyR
Ck = Application _
.Match(C.Offset(, -1).Value, Sh2.Range("A:A"), 0)
If Not IsError(Ck) Then
Sh2.Cells(Ck, 2).Value = C.Value
End If
Next
ELine:
Set MyR = Nothing: Set Sh = Nothing: Set Sh2 = Nothing
End Sub
というコードも考えられます。
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
