關於這件事我真的需要你的幫助,拜託!
我沒有出現任何錯誤,一切都很順利...
我所需要的只是除了匹配 1 到 1 列之外,我還需要匹配 2 到 2 列。
來源工作表中的 A 列到目標工作表中的 G 列(已在此處) 我也想將來源工作表中的 B 列新增至目標工作表中的 H 列。
摘要:將來源工作表(A 和 B)中的 2 列與目標工作表(G 和 H)中的 2 列相符。
我希望你明白我的問題了?謝謝!
程式碼的第一部分:沒有問題
Sub Get_Data()
Const NUM_DATA_COLS As Long = 4
Dim SourceSheet As Worksheet, TargetSheet As Worksheet
Set SourceSheet = GetWorkbook(Source).Worksheets("Data")
Set TargetSheet = ThisWorkbook.Worksheets("Sheet2")
Dim SourceLastRow As Long, TargetLastRow As Long
SourceLastRow = SourceSheet.Cells(Rows.Count, 1).End(xlUp).Row
TargetLastRow = TargetSheet.Cells(Rows.Count, 1).End(xlUp).Row
Dim Primary_Fields(1 To NUM_DATA_COLS), Foreign_Fields(1 To NUM_DATA_COLS), n As Long
Dim i As Long, v, m
Dim rngPrimary_Key As Range
Dim Foreign_Key As Variant
程式碼第二部分:
如何新增另一個 (rngPrimary_Key2) 和 (Foreign_Key2) 以將 2 列配對到 2 列
我只匹配那些
Set rngPrimary_Key = SourceSheet.Range("A2:A" & SourceLastRow)foreign_Key = TargetSheet.Range("G2:G" & TargetLastRow).Value
我需要將它們新增至符合條件中
Set rngPrimary_Key2 = SourceSheet.Range("B2:B" & SourceLastRow)
foreign_Key2 = TargetSheet.Range("H2:H" & TargetLastRow).Value
^- 如果這兩列在兩張表中都匹配,則儲存在數組中而不是僅匹配一列。
Set rngPrimary_Key = SourceSheet.Range("A2:A" & SourceLastRow)
Foreign_Key = TargetSheet.Range("G2:G" & TargetLastRow).Value
For n = 1 To NUM_DATA_COLS
Primary_Fields(n) = SourceSheet.Range("B2:B" & SourceLastRow).Offset(0, n - 1).Value
Foreign_Fields(n) = EmptyCopy(Foreign_Key) 'empty array for results
Next n
' get matching rows and copy values to arrays
For i = LBound(Foreign_Key, 1) To UBound(Foreign_Key, 1)
v = Foreign_Key(i, 1)
m = Application.Match(v, rngPrimary_Key, 0)
If Not IsError(m) Then 'check got a match
For n = 1 To NUM_DATA_COLS
Foreign_Fields(n)(i, 1) = Primary_Fields(n)(m, 1)
Next n
End If
Next i
' / Write (Keys-IndexMatch) in Range offset Foreign_Field_1 2
Place2DArray TargetSheet.Range("H2"), Foreign_Fields(1)
Place2DArray TargetSheet.Range("i2"), Foreign_Fields(2)
Place2DArray TargetSheet.Range("J2"), Foreign_Fields(3)
Place2DArray TargetSheet.Range("K2"), Foreign_Fields(4)
End Sub
其餘程式碼與我的問題無關
'return an empty array of same dimensions as 'arr'
Function EmptyCopy(arr)
Dim rv
ReDim rv(LBound(arr, 1) To UBound(arr, 1), LBound(arr, 2) To UBound(arr, 2))
EmptyCopy = rv
End Function
'copy a 1-based 2-d array 'arr' to a worksheet, starting at cell 'c'
Sub Place2DArray(c As Range, arr)
c.Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
End Sub