Matrix umformatieren

Hallo Insider,
ich habe ein großes Problem und bisher keine Lösung gefunden. Eine Matrix bestehend aus 254 Spalten und 717 Zeilen mit unterschiedlichen Zellinhalten muß in 2 Spalten umformatiert werden. In der 1 Spalte sind Warengruppen und in den darauffolgenden die Prozente der einzelnen Kundengruppen.
Hier ein Ausschnitt: Matrix

	A	B	C	D	E	F	G	H	I	J	K
1	GRUPPE	101	102	103	104	105	106	107	108	109	1010
2	011	40	30	20
3	012	30	25	20	15	10
4	013	14	7
5	014	30	25	20	15	10
6	015	30	25	20	15	10
7	016	30	25	20	15	10
8	017	30	25	20	15	10
9	018	15	10	6	6	6
10	019	20	15	10	8	6
11	020	10	8	5	5	5
12	021	9
13	024	10	5	5	5	5

Excel Tabellen im Web darstellen >> Excel Jeanie HTML 4
Nun soll diese Matrix so aufgeschlüsselt werden:
Beispiel

	A	B	D
1	WGR	Kundengr	Rabatt
2	011	101	40,00
3	011	102	30,00
4	011	103	20,00
5	011	104
6	011	105
7	011	106
8	011	107
9	011	108
10	011	109
11	011	1010
12	011	201	40,00
13	011	202	30,00
14	011	203	20,00
15	011	204
16	011	205
17	011	206
18	011	207

Excel Tabellen im Web darstellen >> Excel Jeanie HTML 4
Mit einer Privottabelle habe ich es schon versucht, habe ich nicht hinbekommen. Es wäre sehr nett wenn sich Einer erbarmen könnte und mir unter die Arme greift.
Schon jetzt für Eure Bemühungen recht vielen Dank.
MfG Burghard

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Hallo,
in ein Modul und von deinem Blatt aus starten:


Sub Matrix()
Dim objM As Object, lngRow As Long, lngCol As Long
Dim arrM(), arrItems, lngI As Long, arrData
Set objM = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
arrData = Cells(1, 1).CurrentRegion
For lngRow = 2 To UBound(arrData)
For lngCol = 2 To UBound(arrData, 2)
objM(arrData(lngRow, 1) & "-" & arrData(1, lngCol)) = _
Array(arrData(lngRow, 1), arrData(1, lngCol), arrData(lngRow, lngCol))
If objM.Count = Rows.Count - 1 Then
arrItems = objM.items
ReDim arrM(1 To objM.Count + 1, 1 To 3)
arrM(1, 1) = "WGR"
arrM(1, 2) = "KdGruppe"
arrM(1, 3) = "Rabatt"
For lngI = 0 To UBound(arrItems)
arrM(lngI + 2, 1) = arrItems(lngI)(0)
arrM(lngI + 2, 2) = arrItems(lngI)(1)
arrM(lngI + 2, 3) = arrItems(lngI)(2)
Next
With Worksheets.Add.Cells(1, 1)
.Resize(UBound(arrM), UBound(arrM, 2)) = arrM
End With
objM.removeall
End If
Next
Next
arrItems = objM.items
ReDim arrM(1 To objM.Count + 1, 1 To 3)
arrM(1, 1) = "WGR"
arrM(1, 2) = "KdGruppe"
arrM(1, 3) = "Rabatt"
For lngI = 0 To UBound(arrItems)
arrM(lngI + 2, 1) = arrItems(lngI)(0)
arrM(lngI + 2, 2) = arrItems(lngI)(1)
arrM(lngI + 2, 3) = arrItems(lngI)(2)
Next
With Worksheets.Add.Cells(1, 1)
.Resize(UBound(arrM), UBound(arrM, 2)) = arrM
End With
End Sub

Gruß
Rudi

Beliebteste Forumthreads (12 Monate)

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread