nach vielen Versuchen habe ich es als Neuling geschaftt, ein Makro aufzuzeichnen und für dieses Abreibtsblatt ablaufen zu lassen.
Wie muss ich das Makro erweitern / verfeinern, damit ich alle neuen Tabellen, die den gleichen Aufbau, aber unterschiedliche Zeilenanzahlen haben, anwenden kann?
Wie kann die Abfrage angehalten werden, wenn die Suche nach PositionsNr. abnimmt (von 9.9.9.9 auf 9.9.9.8?
Die Vorgabe ist für jede Tabelle
in Spalte E "Summe Gruppe 1.1" (kann theoretisch gehen bis "Summe Gruppe 9.9.9.9")
hier meine Makroaufzeichnung:
Sub ZusaFassung()
'
' ZusaFassung Makro
'
'
ActiveWindow.Panes(1).Activate
Range("A1").Select
Cells.Find(What:="gesamt", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False).Activate
Range("E727").Select
ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=ActiveCell
ActiveWindow.Panes(3).Activate
Range("A727").Select
ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=ActiveCell
Range("E729").Select
ActiveCell.FormulaR1C1 = "Zusammenfassung"
Range("E728:I729").Select
Range("E729").Activate
With Selection
.HorizontalAlignment = xlCenterAcrossSelection
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.MergeCells = True
End With
With Selection.Font
.Name = "Times New Roman"
.FontStyle = "Fett"
.Size = 14
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
ActiveWindow.Panes(1).Activate
Range("A1").Select
Cells.Find(What:="Summe Gruppe", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False).Activate
Rows("52:53").Select
Selection.RowHeight = 13.5
Selection.RowHeight = 15
Rows("52:53").EntireRow.AutoFit
Rows("52:54").Select
Selection.Copy
ActiveWindow.Panes(3).Activate
Rows("731:731").Select
Selection.Insert Shift:=xlDown
ActiveWindow.Panes(1).Activate
Range("A54").Select
Cells.FindNext(After:=ActiveCell).Activate
Rows("129:131").Select
Application.CutCopyMode = False
Selection.Copy
ActiveWindow.SmallScroll Down:=5
ActiveWindow.Panes(3).Activate
Rows("734:734").Select
Selection.Insert Shift:=xlDown
ActiveWindow.SmallScroll Down:=4
ActiveWindow.Panes(1).Activate
Range("A131").Select
Cells.FindNext(After:=ActiveCell).Activate
Rows("158:160").Select
Application.CutCopyMode = False
Selection.Copy
ActiveWindow.Panes(3).Activate
Rows("737:737").Select
Selection.Insert Shift:=xlDown
ActiveWindow.Panes(1).Activate
Range("A160").Select
Cells.FindNext(After:=ActiveCell).Activate
Rows("279:281").Select
Application.CutCopyMode = False
Selection.Copy
ActiveWindow.Panes(3).Activate
Rows("740:740").Select
Selection.Insert Shift:=xlDown
ActiveWindow.Panes(1).Activate
Range("A281").Select
Cells.FindNext(After:=ActiveCell).Activate
Rows("688:690").Select
Application.CutCopyMode = False
Selection.Copy
ActiveWindow.SmallScroll Down:=5
ActiveWindow.Panes(3).Activate
Rows("743:743").Select
Selection.Insert Shift:=xlDown
ActiveWindow.Panes(1).Activate
Range("A690").Select
Cells.FindNext(After:=ActiveCell).Activate
Rows("701:703").Select
Application.CutCopyMode = False
Selection.Copy
ActiveWindow.SmallScroll Down:=2
ActiveWindow.Panes(3).Activate
Rows("746:746").Select
Selection.Insert Shift:=xlDown
Selection.FindNext(After:=ActiveCell).Activate
ActiveWindow.Panes(1).Activate
Range("A703").Select
Cells.FindNext(After:=ActiveCell).Activate
Rows("710:712").Select
Application.CutCopyMode = False
Selection.Copy
ActiveWindow.SmallScroll Down:=4
ActiveWindow.Panes(3).Activate
Rows("749:749").Select
Selection.Insert Shift:=xlDown
ActiveWindow.SmallScroll Down:=4
Range("E753").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "Gesamt"
With ActiveCell.Characters(Start:=1, Length:=6).Font
.Name = "Times New Roman"
.FontStyle = "Fett"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Range("F753").Select
ActiveCell.FormulaR1C1 = _
"=SUM(R[-4]C:R[-1]C,R[-7]C,R[-10]C,R[-13]C,R[-16]C,R[-19]C,R[-22]C)"
Range("F753").Select
Selection.Copy
Range("G753").Select
Range(Selection, Selection.End(xlToRight)).Select
ActiveSheet.Paste
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveWindow.LargeScroll ToRight:=-20
ActiveWindow.SmallScroll ToRight:=2
Rows("753:753").Select
Range("C753").Activate
With Selection.Font
.Name = "Times New Roman"
.FontStyle = "Standard"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Rows("753:753").Select
Range("C753").Activate
With Selection
.HorizontalAlignment = xlRight
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.MergeCells = False
End With
Range("E753").Select
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.MergeCells = False
End With
With ActiveSheet.PageSetup
.PrintTitleRows = "$1:$5"
.PrintTitleColumns = ""
End With
ActiveSheet.PageSetup.PrintArea = ""
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = "IWA Wiethoff"
.CenterFooter = ""
.RightFooter = "Seite -&P -"
.LeftMargin = Application.InchesToPoints(0.787401575)
.RightMargin = Application.InchesToPoints(0.787401575)
.TopMargin = Application.InchesToPoints(0.984251969)
.BottomMargin = Application.InchesToPoints(0.984251969)
.HeaderMargin = Application.InchesToPoints(0.4921259845)
.FooterMargin = Application.InchesToPoints(0.4921259845)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = 100
End With
End Sub
Herzlichen Dank
Franz