AW: nochmal Kreuztabelle - ! Bitte mal gucken
31.10.2014 14:35:43
Thorben
Hallo,
ich nochmal!
Das mit der Formel habe ich jetzt verstanden!
Jetzt stehe ich aber vor der großen Datenwand und mit der Formel alleine
wird ganz schön dauern :)
Ich habe mal eine tolle Lösung für ein ähnliches Problem bekommen (siehe unten)
Damit konnte ich meine Matrix innerhalb weniger Sekunden erstellen anstelle von Überläufen und
abbdrüchen aus Zeitrgründen!
Vielleicht mag sich das jemand angucken und evtl. anpassen (das ist ganz klar nicht meine Leistungsklasse!)
Option Explicit
Sub Kreuztab_Verkett()
Dim eDic As Object, uDic As Object, lngQ As Long, arAQ, arHQ, arU
Dim arT() As Long, zz As Long, cc As Long, arK
Set eDic = CreateObject("Scripting.dictionary")
Set uDic = CreateObject("Scripting.dictionary")
With Sheets("---") ' Quelldaten -- Anpassen
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
.Cells(1, 15) = Now - Date ' nur für Test
lngQ = .Cells(.Rows.Count, 1).End(xlUp).Row - 1
arAQ = .Cells(2, 1).Resize(lngQ) ' Spalte Anpassen
arHQ = .Cells(2, 10).Resize(lngQ) ' Spalte Anpassen
End With
With Sheets("---") ' Anpassen
lngQ = .Cells(1, .Columns.Count).End(xlToLeft).Column - 1
arU = .Cells(2, 2).Resize(, lngQ)
For cc = 1 To lngQ
uDic(arU(1, cc)) = cc ' Typen
Next cc
For zz = 1 To UBound(arAQ)
If eDic.Exists(arAQ(zz, 1)) Then
arT = eDic(arAQ(zz, 1)) ' hole Eintrag
If Not arT(uDic(arHQ(zz, 1))) Then
arT(uDic(arHQ(zz, 1))) = True ' Typ kommt vor
eDic(arAQ(zz, 1)) = arT ' schreibe Eintrag
End If
Else
ReDim arT(1 To lngQ)
arT(uDic(arHQ(zz, 1))) = True ' Typ kommt vor
eDic(arAQ(zz, 1)) = arT ' neuer Eintrag
End If
Next zz
arK = eDic.keys
ReDim arE(0 To UBound(arK), 1 To lngQ + 1)
For zz = 0 To UBound(arK)
arT = eDic(arK(zz))
For cc = 1 To lngQ
If arT(cc) Then
arE(zz, cc) = arU(1, cc) ' Typ eintr.
If arE(zz, lngQ + 1) "" Then _
arE(zz, lngQ + 1) = arE(zz, lngQ + 1) & ", " ' verketten
arE(zz, lngQ + 1) = arE(zz, lngQ + 1) & arU(1, cc)
End If
Next cc
Next zz ' Ausgabe
.Cells(2, 1).Resize(UBound(arK) + 1) = Application.Transpose(arK)
.Cells(2, 2).Resize(UBound(arK) + 1, lngQ + 1) = arE
End With
End Sub
Vielen lieben Dank schon mal
MfG
Thorben