AW: 2 Arrays vergleichen
09.02.2010 14:20:09
fcs
Hallo Micha,
hier ein Beispiel mit benutzerdefinierter Funktion. Dürfte bei großeren Arrays etwas schneller sein, als die Arrays komplett in For-Next-Schleifen abzuarbeiten und zu vergleichen. Mehrfach vorkommende Einträge werden in den Ergebnis-Arrays immer nur einmal gelistet.
Gruß
Franz
Sub aaTest()
'Vergleich zweier Daten-Arrays - Erstellt unter Excel 2003
Dim iLfdNr As Long, Zeile As Long, Spalte As Long
Dim arrEqu, arrDif1, arrDif2, arrA, arrB
'Beispieldaten
arrA = Array("AB01", "AB06", "AB05", "AB04", "AB07", "AB03", "AB02", "AB07", "AB03")
arrB = Array("AB01", "AB05", "AB07", "AB03", "AB08", "AB09", "AB10", "AB09")
'benutzerdefinierte Funktion zum Array-Vergleich aufrufen
Call ArrayVergleich(arr01:=arrA, arr02:=arrB, _
arrIn01u02:=arrEqu, _
arrNurin01:=arrDif1, _
arrNurin02:=arrDif2)
'Ergebnis-Arrays ausgeben
Zeile = 1: Spalte = 3
Cells(Zeile, Spalte).Value = "Nur in Array 1"
If IsArray(arrDif1) Then
For iLfdNr = LBound(arrDif1) To UBound(arrDif1)
Zeile = Zeile + 1
Cells(Zeile, Spalte).Value = arrDif1(iLfdNr)
Next
End If
Zeile = 1: Spalte = 4
Cells(Zeile, Spalte).Value = "Nur in Array 2"
If IsArray(arrDif2) Then
For iLfdNr = LBound(arrDif2) To UBound(arrDif2)
Zeile = Zeile + 1
Cells(Zeile, Spalte).Value = arrDif2(iLfdNr)
Next
End If
Zeile = 1: Spalte = 5
Cells(Zeile, Spalte).Value = "beiden Arrays"
If IsArray(arrEqu) Then
For iLfdNr = LBound(arrEqu) To UBound(arrEqu)
Zeile = Zeile + 1
Cells(Zeile, Spalte).Value = arrEqu(iLfdNr)
Next
End If
End Sub
Function ArrayVergleich(arr01, arr02, arrIn01u02, arrNurin01, arrNurin02)
'Vergleich zweier Daten-Arrays - Erstellt unter Excel 2003
Dim iLfdNr As Long, iIndex As Long, iIndexDoppelt As Long
Dim arrBeide(), arrNur1(), arrNur2(), iBeide As Long, iNur1 As Long, iNur2 As Long
On Error Resume Next 'Wenn "Match" Fehler ergibt.
'Array1 mit Array2 abgleichen
For iLfdNr = LBound(arr01) To UBound(arr01)
iIndex = 0: iIndexDoppelt = 0
iIndex = Application.WorksheetFunction.Match(arr01(iLfdNr), arr02, 0)
If iIndex > 0 Then
iIndexDoppelt = Application.WorksheetFunction.Match(arr01(iLfdNr), arrBeide, 0)
If iIndexDoppelt = 0 Then
iBeide = iBeide + 1
ReDim Preserve arrBeide(1 To iBeide)
arrBeide(iBeide) = arr01(iLfdNr)
End If
Else
iIndexDoppelt = Application.WorksheetFunction.Match(arr01(iLfdNr), arrNur1, 0)
If iIndexDoppelt = 0 Then
iNur1 = iNur1 + 1
ReDim Preserve arrNur1(1 To iNur1)
arrNur1(iNur1) = arr01(iLfdNr)
End If
End If
Next
'Array2 mit Array1 abgleichen
For iLfdNr = LBound(arr02) To UBound(arr02)
iIndex = 0: iIndexDoppelt = 0
iIndex = Application.WorksheetFunction.Match(arr02(iLfdNr), arr01, 0)
iIndexDoppelt = Application.WorksheetFunction.Match(arr02(iLfdNr), arrNur2, 0)
If iIndex = 0 And iIndexDoppelt = 0 Then
iNur2 = iNur2 + 1
ReDim Preserve arrNur2(1 To iNur2)
arrNur2(iNur2) = arr02(iLfdNr)
End If
Next
'Ergebnis-Arrays zurückgeben
If iBeide > 0 Then arrIn01u02 = arrBeide
If iNur1 > 0 Then arrNurin01 = arrNur1
If iNur2 > 0 Then arrNurin02 = arrNur2
ReDim arrBeide(0): ReDim arrNur1(0): ReDim arrNur2(0)
End Function