kannst mal testen, ...
21.07.2011 19:31:47
Tino
Hallo,
es sollt nur die erste Übereinstimmung übernommen werden und erst ab Zeile 2.
Tabelle evtl. im Code noch anpassen.
Sub Test()
Dim ArrayTab1(), ArrayTab2(), NewArray()
Dim oDic As Object, oDicMerk As Object
Dim nCount&, A&, B&
Set oDic = CreateObject("Scripting.Dictionary")
Set oDicMerk = CreateObject("Scripting.Dictionary")
With Tabelle1 'Tabelle1 evtl. anpassen
'B2 bis D?
ArrayTab1 = .Range("B2", .Cells(.Rows.Count, 2).End(xlUp)).Resize(, 3)
End With
With Tabelle2 'Tabelle2 evtl. anpassen
'E2 bis H?
ArrayTab2 = .Range("E2", .Cells(.Rows.Count, 5).End(xlUp)).Resize(, 4)
End With
For A = 1 To Ubound(ArrayTab1)
If ArrayTab1(A, 1) <> "" Then _
oDic(ArrayTab1(A, 1)) = ArrayTab1(A, 3)
Next A
nCount = Application.Max(Ubound(ArrayTab1), Ubound(ArrayTab2))
Redim Preserve NewArray(1 To nCount, 1 To 3)
nCount = 0
For A = 1 To Ubound(ArrayTab2)
If oDic.exists(ArrayTab2(A, 1)) Then
If Not oDicMerk.exists(ArrayTab2(A, 1)) Then
nCount = nCount + 1
NewArray(nCount, 1) = ArrayTab2(A, 1)
NewArray(nCount, 2) = oDic(ArrayTab2(A, 1))
NewArray(nCount, 3) = ArrayTab2(A, 4)
oDicMerk(ArrayTab2(A, 1)) = 0
End If
End If
Next A
If nCount > 0 Then
With ThisWorkbook
With .Sheets.Add(After:=.Sheets(.Sheets.Count))
With .Cells(2, 1).Resize(Ubound(NewArray), Ubound(NewArray, 2))
.Value = NewArray
.EntireColumn.AutoFit
End With
End With
End With
End If
End Sub
Gruß Tino