AW: Inhalte zusammenführen
21.01.2010 08:58:52
Tino
Hallo,
müsste funktionieren.
Sub Test()
Dim meAR(), meDic(1 To 6) As Object
Dim A As Long, AA As Long
For A = 1 To 6
Set meDic(A) = CreateObject("Scripting.Dictionary")
Next A
meAR = Range("A2", Cells(Rows.Count, 8).End(xlUp)).Value2
For A = 1 To Ubound(meAR)
If meDic(1).exists(meAR(A, 1)) Then
meDic(1)(meAR(A, 1)) = meDic(1)(meAR(A, 1)) & ", " & meAR(A, 2) 'Spalte B
meDic(2)(meAR(A, 1)) = meDic(2)(meAR(A, 1)) & ", " & meAR(A, 4) 'Spalte D
meDic(3)(meAR(A, 1)) = meDic(3)(meAR(A, 1)) & ", " & meAR(A, 5) 'Spalte E
meDic(4)(meAR(A, 1)) = meDic(4)(meAR(A, 1)) & ", " & meAR(A, 6) 'Spalte F
meDic(5)(meAR(A, 1)) = meDic(5)(meAR(A, 1)) & ", " & meAR(A, 7) 'Spalte G
meDic(6)(meAR(A, 1)) = meDic(6)(meAR(A, 1)) & ", " & meAR(A, 8) 'Spalte H
Else
For AA = 1 To 6
meDic(AA)(meAR(A, 1)) = meAR(A, 2)
Next AA
End If
Next A
With Application
Range("A2").Resize(Ubound(meAR), 8).ClearContents
Range("A2").Resize(meDic(1).Count) = .Transpose(meDic(1).keys)
Range("B2").Resize(meDic(1).Count) = .Transpose(meDic(1).items)
Range("D2").Resize(meDic(2).Count) = .Transpose(meDic(2).items)
Range("E2").Resize(meDic(3).Count) = .Transpose(meDic(3).items)
Range("F2").Resize(meDic(4).Count) = .Transpose(meDic(4).items)
Range("G2").Resize(meDic(5).Count) = .Transpose(meDic(5).items)
Range("H2").Resize(meDic(6).Count) = .Transpose(meDic(6).items)
End With
End Sub
Aber was ist mit Deiner Spalte 3?
Im Beispiel war es die die Spalte 2 und bei Deiner zweiten Frage geht es erst ab Spalte 4 weiter?
Gruß Tino