Ich brauche in dieser Angelegenheit wirklich Ihre Hilfe, bitte!
Ich habe keinen Fehler, alles funktioniert reibungslos....
Ich brauche nur, dass außer der 1:1-Spalte auch die 2:2-Spalten abgeglichen werden.
Spalte A im Quellblatt zu Spalte G im Zielblatt (bereits hier). Ich möchte außerdem Spalte B im Quellblatt zu Spalte H im Zielblatt hinzufügen.
Zusammenfassung: Ordnen Sie 2 Spalten im Quellblatt (A und B) 2 Spalten im Zielblatt (G und H) zu.
Ich hoffe, Sie haben meine Frage verstanden? Danke!
Erster Teil des Codes: Kein Problem
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
Zweiter Teil des Codes:
So fügen Sie einen weiteren (rngPrimary_Key2) und (Foreign_Key2) hinzu, um 2 Spalten mit 2 Spalten abzugleichen
Ich vergleiche nur diese
Set rngPrimary_Key = SourceSheet.Range("A2:A" & SourceLastRow) Foreign_Key = TargetSheet.Range("G2:G" & TargetLastRow).Value
Ich muss diese zu den Übereinstimmungskriterien hinzufügen.
Set rngPrimary_Key2 = SourceSheet.Range("B2:B" & SourceLastRow)
Foreign_Key2 = TargetSheet.Range("H2:H" & TargetLastRow).Value
^- Wenn diese beiden Spalten in beiden Blättern übereinstimmen, dann in einem Array speichern, anstatt nur eine Spalte abzugleichen.
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
Der Rest des Codes hat nichts mit meiner Frage zu tun
'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