hier noch mein überarbeitetes Script:
Sub Liste()
' Liste Makro
' Tastenkombination: Strg+l
# markiere Spalte und füge eine neue mit Verschiebung nach rechts ein
Columns("F:F").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
# setze von Spaltenbreiten
Columns("A:A").ColumnWidth = 7.00
Columns("B:B").ColumnWidth = 25.00
Columns("C:C").ColumnWidth = 9.00
Columns("D:D").ColumnWidth = 9.00
Columns("E:E").ColumnWidth = 9.00
Columns("F:F").ColumnWidth = 11.00
Columns("G:G").ColumnWidth = 3.00
Columns("H:H").ColumnWidth = 7.00
Columns("I:I").ColumnWidth = 25.00
Columns("J:J").ColumnWidth = 9.00
Columns("K:K").ColumnWidth = 9.00
Columns("L:L").ColumnWidth = 9.00
Columns("M:M").ColumnWidth = 11.00
# markiere Zellen und schneide die Zellen mit Verschiebung nach oben aus
Range("A3:M3").Select
Selection.Delete Shift:=xlUp
Range("H24:L24").Select
Selection.Delete Shift:=xlUp
Range("A24:F24").Select
Selection.Delete Shift:=xlUp
Range("A59:M59").Select
Selection.Delete Shift:=xlUp
Range("A59:F59").Select
Selection.Delete Shift:=xlUp
Range("H59:M59").Select
Selection.Delete Shift:=xlUp
Range("A115:M115").Select
Selection.Delete Shift:=xlUp
Range("A115:M115").Select
Selection.Delete Shift:=xlUp
# markiere Zellen und füge eine neue Zeile mit Verschiebung nach unten ein
Range("A4:M4").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A60:F60").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("H60:M60").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A23:F23").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("H32:M32").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A61:F61").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("H62:M62").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A91:F91").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("H92:M92").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("H108:M108").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A120:F120").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("H121:M121").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A138:F138").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("H151:M151").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
# schneide Zellen aus und füge Sie woanders ein
Range("C25").Select
Selection.Cut
Range("B25").Select
ActiveSheet.Paste
Range("C121").Select
Selection.Cut
Range("B121").Select
ActiveSheet.Paste
# lege in Spalte F & M das Format m³ fest
Columns("F:F").Select
Selection.NumberFormat = "0.00 ""m³"""
Columns("M:M").Select
Selection.NumberFormat = "0.00 ""m³"""
# mache Zelle rot
Range("B5,B25,B63,B92,B121,B139,I152,I122,I109,I93,I63,I34,I5").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent2
.TintAndShade = 0.799981688894314
.PatternTintAndShade = 0
End With
# fügt die Summenschriftfelder ein
Range("B23").Select
ActiveCell.FormulaR1C1 = "Summe"
Range("B61").Select
ActiveCell.FormulaR1C1 = "Summe"
Range("B90").Select
ActiveCell.FormulaR1C1 = "Summe"
Range("B119").Select
ActiveCell.FormulaR1C1 = "Summe"
Range("B137").Select
ActiveCell.FormulaR1C1 = "Summe"
Range("B177").Select
ActiveCell.FormulaR1C1 = "Summe"
Range("I178").Select
ActiveCell.FormulaR1C1 = "Summe"
Range("I150").Select
ActiveCell.FormulaR1C1 = "Summe"
Range("I120").Select
ActiveCell.FormulaR1C1 = "Summe"
Range("I107").Select
ActiveCell.FormulaR1C1 = "Summe"
Range("I91").Select
ActiveCell.FormulaR1C1 = "Summe"
Range("I61").Select
ActiveCell.FormulaR1C1 = "Summe"
Range("I32").Select
ActiveCell.FormulaR1C1 = "Summe"
# gehe in Zelle & füge Summenformel ein, kopiere diese bis Ende Block
Range("F6").Select
ActiveCell.FormulaR1C1 = "=RC[-1]*RC[-2]*RC[-3]/1000000*RC[-5]"
Range("F6:F22").Select
Selection.FillDown
Range("F26").Select
ActiveCell.FormulaR1C1 = "=RC[-1]*RC[-2]*RC[-3]/1000000*RC[-5]"
Range("F26:F60").Select
Selection.FillDown
Range("F64").Select
ActiveCell.FormulaR1C1 = "=RC[-1]*RC[-2]*RC[-3]/1000000*RC[-5]"
Range("F64:F89").Select
Selection.FillDown
Range("F93").Select
ActiveCell.FormulaR1C1 = "=RC[-1]*RC[-2]*RC[-3]/1000000*RC[-5]"
Range("F93:F118").Select
Selection.FillDown
Range("F122").Select
ActiveCell.FormulaR1C1 = "=RC[-1]*RC[-2]*RC[-3]/1000000*RC[-5]"
Range("F122:F136").Select
Selection.FillDown
Range("F140").Select
ActiveCell.FormulaR1C1 = "=RC[-1]*RC[-2]*RC[-3]/1000000*RC[-5]"
Range("F140:F176").Select
Selection.FillDown
Range("M6").Select
ActiveCell.FormulaR1C1 = "=RC[-1]*RC[-2]*RC[-3]/1000000*RC[-5]"
Range("M6:M31").Select
Selection.FillDown
Range("M35").Select
ActiveCell.FormulaR1C1 = "=RC[-1]*RC[-2]*RC[-3]/1000000*RC[-5]"
Range("M35:M60").Select
Selection.FillDown
Range("M64").Select
ActiveCell.FormulaR1C1 = "=RC[-1]*RC[-2]*RC[-3]/1000000*RC[-5]"
Range("M64:M90").Select
Selection.FillDown
Range("M94").Select
ActiveCell.FormulaR1C1 = "=RC[-1]*RC[-2]*RC[-3]/1000000*RC[-5]"
Range("M94:M106").Select
Selection.FillDown
Range("M110").Select
ActiveCell.FormulaR1C1 = "=RC[-1]*RC[-2]*RC[-3]/1000000*RC[-5]"
Range("M110:M119").Select
Selection.FillDown
Range("M123").Select
ActiveCell.FormulaR1C1 = "=RC[-1]*RC[-2]*RC[-3]/1000000*RC[-5]"
Range("M123:M149").Select
Selection.FillDown
Range("M153").Select
ActiveCell.FormulaR1C1 = "=RC[-1]*RC[-2]*RC[-3]/1000000*RC[-5]"
Range("M153:M177").Select
Selection.FillDown
# gehe in Zelle und füge Summenformel von - bis ein
Range("F23").Select
ActiveCell.FormulaR1C1 = "=SUM(R[-17]C:R[-1]C)"
Range("F61").Select
ActiveCell.FormulaR1C1 = "=SUM(R[-35]C:R[-1]C)"
Range("F90").Select
ActiveCell.FormulaR1C1 = "=SUM(R[-26]C:R[-1]C)"
Range("F119").Select
ActiveCell.FormulaR1C1 = "=SUM(R[-26]C:R[-1]C)"
Range("F137").Select
ActiveCell.FormulaR1C1 = "=SUM(R[-15]C:R[-1]C)"
Range("F177").Select
ActiveCell.FormulaR1C1 = "=SUM(R[-37]C:R[-1]C)"
Range("M32").Select
ActiveCell.FormulaR1C1 = "=SUM(R[-26]C:R[-1]C)"
Range("M61").Select
ActiveCell.FormulaR1C1 = "=SUM(R[-26]C:R[-1]C)"
Range("M91").Select
ActiveCell.FormulaR1C1 = "=SUM(R[-27]C:R[-1]C)"
Range("M107").Select
ActiveCell.FormulaR1C1 = "=SUM(R[-13]C:R[-1]C)"
Range("M120").Select
ActiveCell.FormulaR1C1 = "=SUM(R[-10]C:R[-1]C)"
Range("M150").Select
ActiveCell.FormulaR1C1 = "=SUM(R[-27]C:R[-1]C)"
Range("M178").Select
ActiveCell.FormulaR1C1 = "=SUM(R[-25]C:R[-1]C)"
# mache Zelle gelb
Range("B23,F23,B61,F61,B90,F90,B119,F119,B137,F137,B177,F177,I32,M32,I61,M61,I91,M91,I107, _
M107,I120,M120,I150,M150,I178,M178").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
# fügt die Gesamt-Summenfelder & Stückzahl ein
Range("I1").Select
ActiveCell.FormulaR1C1 = "Gesamtkubikmeter"
Range("I2").Select
ActiveCell.FormulaR1C1 = "Gesamtstückzahl"
Range("I1:I2").Select
Selection.Font.Size = 12
Selection.Font.Bold = True
With Selection.Font
.Color = -16776961
.TintAndShade = 0
End With
# verbinden von Zellen
Range("J1:K1").Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Range("J2:K2").Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
# Gesamtkubikmeter berechnen
Range("J1:K1").Select
ActiveCell.FormulaR1C1 = _
"=R[22]C[-4]+R[60]C[-4]+R[89]C[-4]+R[118]C[-4]+R[176]C[-4]+R[177]C[3]+R[149]C[3]+R[119] _
C[3]+R[106]C[3]+R[90]C[3]+R[60]C[3]+R[31]C[3]"
Range("J2:K2").Select
# Gesamtstückzahl berechnen
Range("J2:K2").Select
ActiveCell.FormulaR1C1 = _
"=SUM(R[2]C[-9]:R[178]C[-9])+(SUM(R[2]C[-2]:R[178]C[-2]))"
Range("J2:K2").Select
# Endungen & Formatierung oben festlegen
Range("J1:K1").Select
Selection.NumberFormat = "0.00 ""m³"""
Range("J2:K2").Select
Selection.NumberFormat = "0 ""Stück"""
Range("J1:K2").Select
Range("J2").Activate
Selection.Font.Bold = True
With Selection.Font
.Color = -16776961
.TintAndShade = 0
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
End With
# Absätze sortieren
Range("A6:F22").Select
ActiveWorkbook.Worksheets(1).Sort.SortFields.Clear
ActiveWorkbook.Worksheets(1).Sort.SortFields.Add _
Key:=Range("A6"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
:=xlSortNormal
With ActiveWorkbook.Worksheets(1).Sort
.SetRange Range("A6:F22")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("A26:F60").Select
ActiveWorkbook.Worksheets(1).Sort.SortFields.Clear
ActiveWorkbook.Worksheets(1).Sort.SortFields.Add _
Key:=Range("A26"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
:=xlSortNormal
With ActiveWorkbook.Worksheets(1).Sort
.SetRange Range("A26:F60")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("A64:F89").Select
ActiveWorkbook.Worksheets(1).Sort.SortFields.Clear
ActiveWorkbook.Worksheets(1).Sort.SortFields.Add _
Key:=Range("A64"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
:=xlSortNormal
With ActiveWorkbook.Worksheets(1).Sort
.SetRange Range("A64:F89")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("A93:F118").Select
ActiveWorkbook.Worksheets(1).Sort.SortFields.Clear
ActiveWorkbook.Worksheets(1).Sort.SortFields.Add _
Key:=Range("A93"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
:=xlSortNormal
With ActiveWorkbook.Worksheets(1).Sort
.SetRange Range("A93:F118")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("A122:F136").Select
ActiveWorkbook.Worksheets(1).Sort.SortFields.Clear
ActiveWorkbook.Worksheets(1).Sort.SortFields.Add _
Key:=Range("A122"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
:=xlSortNormal
With ActiveWorkbook.Worksheets(1).Sort
.SetRange Range("A122:F136")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("A140:F176").Select
ActiveWorkbook.Worksheets(1).Sort.SortFields.Clear
ActiveWorkbook.Worksheets(1).Sort.SortFields.Add _
Key:=Range("A140"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
:=xlSortNormal
With ActiveWorkbook.Worksheets(1).Sort
.SetRange Range("A140:F176")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("H6:M31").Select
ActiveWorkbook.Worksheets(1).Sort.SortFields.Clear
ActiveWorkbook.Worksheets(1).Sort.SortFields.Add _
Key:=Range("H6"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
:=xlSortNormal
With ActiveWorkbook.Worksheets(1).Sort
.SetRange Range("H6:M31")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("H35:M60").Select
ActiveWorkbook.Worksheets(1).Sort.SortFields.Clear
ActiveWorkbook.Worksheets(1).Sort.SortFields.Add _
Key:=Range("H35"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
:=xlSortNormal
With ActiveWorkbook.Worksheets(1).Sort
.SetRange Range("H35:M60")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("H64:M90").Select
ActiveWorkbook.Worksheets(1).Sort.SortFields.Clear
ActiveWorkbook.Worksheets(1).Sort.SortFields.Add _
Key:=Range("H64"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
:=xlSortNormal
With ActiveWorkbook.Worksheets(1).Sort
.SetRange Range("H64:M90")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("H94:M106").Select
ActiveWorkbook.Worksheets(1).Sort.SortFields.Clear
ActiveWorkbook.Worksheets(1).Sort.SortFields.Add _
Key:=Range("H94"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
:=xlSortNormal
With ActiveWorkbook.Worksheets(1).Sort
.SetRange Range("H94:M106")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("H110:M119").Select
ActiveWorkbook.Worksheets(1).Sort.SortFields.Clear
ActiveWorkbook.Worksheets(1).Sort.SortFields.Add _
Key:=Range("H110"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
:=xlSortNormal
With ActiveWorkbook.Worksheets(1).Sort
.SetRange Range("H110:M119")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("H123:M149").Select
ActiveWorkbook.Worksheets(1).Sort.SortFields.Clear
ActiveWorkbook.Worksheets(1).Sort.SortFields.Add _
Key:=Range("H123"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
:=xlSortNormal
With ActiveWorkbook.Worksheets(1).Sort
.SetRange Range("H123:M149")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("H153:M177").Select
ActiveWorkbook.Worksheets(1).Sort.SortFields.Clear
ActiveWorkbook.Worksheets(1).Sort.SortFields.Add _
Key:=Range("H153"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
:=xlSortNormal
With ActiveWorkbook.Worksheets(1).Sort
.SetRange Range("H153:M177")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
# oben auswählen & speichern als xls
Range("A4").Select
ChDir "C:\............."
ActiveWorkbook.SaveAs _
FileFormat:=xlExcel5, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
# Nuller entfernen
Dim lngL As Long
For lngL = Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1
If Cells(lngL, 1).Value "" Then
If Cells(lngL, 1).Value = 0 Then
Range("A" & lngL & ":F" & lngL).Delete xlUp
End If
End If
Next lngL
For lngL = Cells(Rows.Count, 8).End(xlUp).Row To 1 Step -1
If Cells(lngL, 8).Value "" Then
If Cells(lngL, 8).Value = 0 Then
Range("H" & lngL & ":M" & lngL).Delete xlUp
End If
End If
Next lngL
End Sub
