AW: Tabelle mit Macro transponieren
29.01.2014 14:21:27
fcs
Hallo Martin,
das war jetzt doch eine relativ umfangreiche Fleißarbeit bei der Makroerstellung.
Gruß
Franz
Sub Umgruppieren()
Dim wksQ As Worksheet, wksZ As Worksheet
Dim Zeile_Q As Long, Zeile_Z As Long
Dim ZeileBP As Long, ZeileOrg As Long, SpalteSys As Long
Dim ZeileBP_1 As Long, ZeileBP_L As Long
Dim ZeileOrg_1 As Long, ZeileOrg_L As Long
Dim SpalteSys_1 As Long, SpalteSys_L As Long
Dim Spalte_Z As Long, SpalteZ_BP1 As Long, SpalteZ_sys As Long
Dim varSys, varBP
Application.ScreenUpdating = False
Set wksQ = ActiveSheet
'neues Tabellenblatt für umgruppierte Daten anlegen
ActiveWorkbook.Worksheets.Add after:=wksQ
Set wksZ = ActiveSheet
With wksQ
'Startzeilen- und Spaltenummern im Quellblatt festlegen/berechnen
ZeileBP_1 = 2
ZeileBP_L = .Cells(ZeileBP_1, 1).End(xlDown).Row
ZeileOrg_1 = ZeileBP_L + 2
ZeileOrg_L = .Cells(.Rows.Count, 1).End(xlUp).Row
SpalteSys_1 = 2
SpalteSys_L = .Cells(1, .Columns.Count).End(xlToLeft).Column
'Org-Namen im Zielblatt Spalte A eintragen
Zeile_Z = 1
For Zeile_Q = ZeileOrg_1 To ZeileOrg_L
Zeile_Z = Zeile_Z + 1
wksZ.Cells(Zeile_Z, 1).Value = .Cells(Zeile_Q, 1).Value
Next
End With 'wksQ
'Orgwerte im Zielblatt formatieren
With wksZ
With .Range(.Cells(2, 1), .Cells(Zeile_Z, 1))
.Interior.Color = 12566463 'grau
With .Borders
.LineStyle = xlContinuous
.Weight = xlThin
End With
.Font.Color = 16777215 'weiß
.EntireColumn.AutoFit
End With
End With
'BP-Werte abarbeiten
Spalte_Z = 1 'Spalte mit Orgnamen im Zielblatt
For ZeileBP = ZeileBP_1 To ZeileBP_L
varBP = wksQ.Cells(ZeileBP, 1)
SpalteZ_BP1 = Spalte_Z + 1
'System-Werte abarbeiten
For SpalteSys = SpalteSys_1 To SpalteSys_L
varSys = wksQ.Cells(1, SpalteSys)
If LCase(wksQ.Cells(ZeileBP, SpalteSys)) = "x" Then
'Orgwerte abarbeiten
For ZeileOrg = ZeileOrg_1 To ZeileOrg_L
If LCase(wksQ.Cells(ZeileOrg, SpalteSys)) = "x" Then
With wksZ
'letzte belegte Spalte in Org-Zeile im Zielblatt ermitteln
Zeile_Z = 2 + ZeileOrg - ZeileOrg_1
SpalteZ_sys = .Cells(Zeile_Z, .Columns.Count).End(xlToLeft).Column
'Einfügespalte und Spalte des letzten Systems zur BP ermitteln
If SpalteZ_sys Spalte_Z Then
Spalte_Z = SpalteZ_sys
End If
End If
.Cells(1, SpalteZ_BP1).Value = varBP
.Cells(Zeile_Z, SpalteZ_sys).Value = varSys
End With 'wksZ
End If
Next ZeileOrg
End If
Next SpalteSys
If Spalte_Z >= SpalteZ_BP1 Then
'Rahmen zum BP-Werte-Bereich formatieren
With wksZ
Zeile_Z = 2 + ZeileOrg_L - ZeileOrg_1
With .Range(.Cells(1, SpalteZ_BP1), .Cells(Zeile_Z, Spalte_Z))
With .Borders
.LineStyle = xlContinuous
End With
.Borders(xlEdgeTop).Weight = xlMedium
.Borders(xlEdgeBottom).Weight = xlMedium
.Borders(xlEdgeLeft).Weight = xlMedium
.Borders(xlEdgeRight).Weight = xlMedium
.Borders(xlInsideHorizontal).Weight = xlThin
.Borders(xlInsideVertical).Weight = xlThin
End With
End With 'wksZ
End If
Next ZeileBP
'Titelzeile mit BP-Werten formatieren
With wksZ
With .Range(.Cells(1, 2), .Cells(1, Spalte_Z))
.HorizontalAlignment = xlCenterAcrossSelection
.Interior.Color = 12566463 'grau
.Font.Color = 16777215 'weiß
.EntireColumn.AutoFit
End With
End With 'wksZ
Application.ScreenUpdating = True
End Sub
