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
Die erweiterte Suchfunktion hilft dir, gezielt die besten Antworten zu finden
Suche nach den besten AntwortenEntdecke unsere meistgeklickten Beiträge in der Google Suche
Top 100 Threads jetzt ansehen