Kreuztabelle erstellen, Daten in Array einlesen
29.11.2011 07:51:26
fcs
Hallo Kay,
das folgende Makro erstellt ein entsprechendes Daten-Array.
Das Makro erstellt temporär ein Tabellenblatt, um die Daten aufzubereiten und dann in ein Array zu übernehmen.
Gruß
Franz
Sub aaTest()
Dim wks As Worksheet
Dim varMatrix As Variant
Set wks = Worksheets("Tabelle")
With wks
Application.ScreenUpdating = False
varMatrix = MatrixErzeugen(Bereich:=.Range(.Cells(1, 1) _
, .Cells(.Rows.Count, 1).End(xlUp).Offset(0, 2)))
'Testausgabe der Matrix ab Zelle F1
'1. Spalte und 1. Zeile der Matrix haben den Zähler 1!!!
Dim iI As Long, iJ As Long
For iI = LBound(varMatrix, 1) To UBound(varMatrix, 1)
For iJ = LBound(varMatrix, 2) To UBound(varMatrix, 2)
.Range("F1").Offset(iI - 1, iJ - 1).Value = varMatrix(iI, iJ)
Next
Next
Application.ScreenUpdating = True
End With
End Sub
Function MatrixErzeugen(Bereich As Range) As Variant
'Erzeugt aus einer Liste mit 3 Spalten eine Matrix der Kreuztabelle
Dim wksZ As Worksheet
Dim Zeile As Long, ZeileZ As Long, SpalteZ As Long, ZelleZ As Range
Dim varWG, varUWG
'temporäres Tabellenblatt anlegen für Kreuztabellen-Matrix
Set wksZ = Worksheets.Add
With wksZ
'Spaltentitel in Zielblatt übernehmen
Zeile = 1
ZeileZ = 1
.Cells(ZeileZ, 1) = Bereich.Cells(Zeile, 2)
'Werte ab Zeile 2 abarbeiten
For Zeile = 2 To Bereich.Rows.Count
varUWG = Bereich.Cells(Zeile, 2)
varWG = Bereich.Cells(Zeile, 3)
If Zeile = 2 Then
ZeileZ = 2: SpalteZ = 2
.Cells(ZeileZ, 1) = varUWG
.Cells(1, SpalteZ) = varWG
Else
'UWG in Spalte A suchen
Set ZelleZ = .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp)) _
.Find(what:=varUWG, LookIn:=xlValues, lookat:=xlWhole)
If ZelleZ Is Nothing Then
ZeileZ = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
.Cells(ZeileZ, 1).Value = varUWG
Else
ZeileZ = ZelleZ.Row
End If
'WG in Zeile 1 suchen
Set ZelleZ = .Range(.Cells(1, 2), .Cells(1, .Columns.Count).End(xlToLeft)) _
.Find(what:=varWG, LookIn:=xlValues, lookat:=xlWhole)
If ZelleZ Is Nothing Then
SpalteZ = .Cells(1, .Columns.Count).End(xlToLeft).Column + 1
.Cells(1, SpalteZ).Value = varWG
Else
SpalteZ = ZelleZ.Column
End If
End If
.Cells(ZeileZ, SpalteZ) = "x"
Next
'Matrix nach Zeilen und Spalten sortieren
ZeileZ = .Cells(.Rows.Count, 1).End(xlUp).Row
SpalteZ = .Cells(1, .Columns.Count).End(xlToLeft).Column
If ZeileZ > 2 Then
With .Range(.Cells(1, 1), .Cells(ZeileZ, SpalteZ))
.Sort key1:=Range("A1"), Order1:=xlAscending, Header:=xlYes, Orientation:=xlSortColumns
End With
End If
If SpalteZ > 2 Then
With .Range(.Cells(1, 2), .Cells(ZeileZ, SpalteZ))
.Sort key1:=Range("A1"), Order1:=xlAscending, Header:=xlYes, Orientation:=xlSortRows
End With
End If
'Text aus Zeile 1, Spalte 3 der Liste in der Zeile1 vor den Zellinhalten einfügen
For SpalteZ = 2 To SpalteZ
.Cells(1, SpalteZ).Value = Bereich.Cells(1, 3).Value & " " & .Cells(1, SpalteZ).Value
Next
MatrixErzeugen = .Range(.Cells(1, 1), .Cells(ZeileZ, SpalteZ))
'temporäres Tabellenblatt wieder löschen
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = False
End With
End Function