Kann mir jemand sagen, wie ich das beigefügte Script anpassen kann?
Ich kriegs nicht hin....
Die Quellspalten liegen anstatt:
A bei K
B bei I
und C bei J
Beginnend ab Zeile 2
Die Zielausgabe liegt anstatt in Spalte:
A bei C
B bei D
und C bei G
Beginnend ab Zeile 2
------------------------------------------------
Sub Start_Beispiel()
Dim oDic(1 To 3) As Object
Dim meAr()
Dim A&, LRow&
Dim tmpText$
For A = 1 To 3
Set oDic(A) = CreateObject("Scripting.Dictionary")
Next A
With Tabelle1
meAr = .Range("A2", .Cells(.Rows.Count, 1).End(xlUp)).Resize(, 3)
End With
For A = 1 To UBound(meAr)
tmpText = meAr(A, 1) & meAr(A, 2)
If oDic(1).Exists(tmpText) Then
oDic(3)(tmpText) = oDic(3)(tmpText) + meAr(A, 3)
Else
oDic(1)(tmpText) = meAr(A, 1)
oDic(2)(tmpText) = meAr(A, 2)
oDic(3)(tmpText) = meAr(A, 3)
End If
Next A
With Tabelle2
LRow = .UsedRange.Rows(.UsedRange.Rows.Count).Row
If LRow > 2 Then
.Range("A2:C2").Resize(LRow - 1).Clear
End If
.Range("A1").Resize(oDic(1).Count) = WorksheetFunction.Transpose(oDic(1).Items)
.Range("B1").Resize(oDic(2).Count) = WorksheetFunction.Transpose(oDic(2).Items)
.Range("C1").Resize(oDic(3).Count) = WorksheetFunction.Transpose(oDic(3).Items)
.Select
End With
End Sub