Sub umgruppieren()
Dim shQuelle As Worksheet
Dim shZiel As Worksheet
Dim Quelldaten
Dim zeQ As Long
Dim spQ As Long
Dim zeZ As Long
Dim spZ As Long
Dim x As Long
Dim i As Long
Set shQuelle = Sheets("rohdaten")
Set shZiel = Sheets("Tabelle1")
shZiel.Cells.Clear
Quelldaten = shQuelle.UsedRange
x = shQuelle.Rows(2).Find(what:="original").Column
With shZiel
'--- Überschriften
For spQ = 1 To x - 1
.Cells(1, spQ) = Quelldaten(2, spQ)
Next
spZ = x
For spQ = x To UBound(Quelldaten, 2) Step 4
spZ = spZ + 1
.Cells(1, spZ) = Quelldaten(1, spQ)
Next
'---Daten---
zeZ = -2
For zeQ = 3 To UBound(Quelldaten, 1)
zeZ = zeZ + 4
spZ = 0
For spQ = 1 To x - 1
spZ = spZ + 1
.Cells(zeZ, spZ).Resize(4, 1) = Quelldaten(zeQ, spQ)
Next
spZ = x
For i = 0 To 3
.Cells(zeZ + i, spZ) = Quelldaten(2, x + i)
Next
For spQ = x To UBound(Quelldaten, 2) Step 4
spZ = spZ + 1
For i = 0 To 3
.Cells(zeZ + i, spZ) = Quelldaten(zeQ, spQ + i)
Next
Next
Next
'--- Sortierung
For i = x - 1 To 1 Step -1
.UsedRange.Sort key1:=.Cells(2, i), order1:=xlAscending, header:=xlYes
Next
.Select
End With
'--- Formatierung
zeZ = zeZ + 3
Cells.FormatConditions.Delete
With Range(Cells(1, 1), Cells(zeZ, x - 1))
.Select
.FormatConditions.Add Type:=xlExpression, Formula1:="=A1=A65536"
.FormatConditions(1).Font.ColorIndex = 2
.FormatConditions.Add Type:=xlExpression, Formula1:="=A1A65536"
.FormatConditions(2).Borders(xlTop).Weight = xlThin
.Borders(xlEdgeBottom).Weight = xlThin
.Borders(xlEdgeTop).Weight = xlThin
.Borders(xlEdgeLeft).Weight = xlThin
.Borders(xlEdgeRight).Weight = xlThin
.Borders(xlInsideVertical).Weight = xlThin
End With
With Range(Cells(1, x), Cells(zeZ, spZ))
.Select
.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, Formula1:="=""grün"""
.FormatConditions(1).Interior.ColorIndex = 4
.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, Formula1:="=""gelb"""
.FormatConditions(2).Interior.ColorIndex = 6
.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, Formula1:="=""rot"""
.FormatConditions(3).Interior.ColorIndex = 3
.Borders(xlEdgeBottom).Weight = xlThin
.Borders(xlEdgeTop).Weight = xlThin
.Borders(xlEdgeLeft).Weight = xlThin
.Borders(xlEdgeRight).Weight = xlThin
.Borders(xlInsideHorizontal).Weight = xlThin
.Borders(xlInsideVertical).Weight = xlThin
End With
With Rows(1)
.HorizontalAlignment = xlCenter
.Font.Bold = True
End With
Rows("2:2").Select
ActiveWindow.FreezePanes = True
Cells.EntireColumn.AutoFit
End Sub
Gruß, Daniel