AW: Makroausführung verschluckt Codezeile
20.11.2023 12:49:50
ExcelMoonRise
so, damit ihr den Gesamtkontext seht, wobei ich (als Laie xD) bezweifle das da ein Fehler drin steckt ... aber vielleicht laienhaft geschrieben
Option Explicit
Sub KomplettesEtikettenMakro()
Dim Etikettenzähler As Long
'------ Das Worddokument anpassen -----------------------------------------------------
With ActiveDocument.PageSetup
.TopMargin = CentimetersToPoints(0.6)
.BottomMargin = CentimetersToPoints(0.5)
.LeftMargin = CentimetersToPoints(0.5)
.RightMargin = CentimetersToPoints(0.5)
.HeaderDistance = CentimetersToPoints(0.6)
.FooterDistance = CentimetersToPoints(0.6)
End With
'------ Das Tabellengerüst des Etikettenblattes erstellen ------------------------------
ActiveDocument.Tables.Add Range:=Selection.Range, NumRows:=5, NumColumns:=3, _
DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:=wdAutoFitFixed
ActiveDocument.Tables(1).Borders.Enable = False
' ActiveDocument.Tables(1).Select
With Selection.Tables(1)
.AllowPageBreaks = True
.AllowAutoFit = False
.Rows.HeightRule = wdRowHeightExactly
.Rows.Height = CentimetersToPoints(5.7)
.Columns.PreferredWidthType = wdPreferredWidthPoints
.Columns.PreferredWidth = CentimetersToPoints(9.9)
' .Columns(2).PreferredWidthType = wdPreferredWidthPoints
.Columns(2).PreferredWidth = CentimetersToPoints(0.3)
'
' End With
'------ Die Etikettentabellen formatiert einfügen -----------------------------------------------------
ActiveDocument.Tables.Add Range:=Selection.Range, NumRows:=4, NumColumns:=3
'------------------Zeile 1------------------------------------------------
ActiveDocument.Range(0, 3).Select
With Selection
.Cells.Merge
With .Rows
.HeightRule = wdRowHeightExactly
.Height = CentimetersToPoints(1.8)
End With
With .Cells(1)
.TopPadding = CentimetersToPoints(0.15)
.BottomPadding = CentimetersToPoints(0.15)
.LeftPadding = CentimetersToPoints(0.19)
.RightPadding = CentimetersToPoints(0.19)
.WordWrap = True
.FitText = False
End With
With .Font
.Name = "Arial"
.Size = 14
.Bold = wdToggle
End With
With .ParagraphFormat
.SpaceBeforeAuto = False
.SpaceAfterAuto = False
.LeftIndent = CentimetersToPoints(0.75)
.FirstLineIndent = CentimetersToPoints(0)
.RightIndent = CentimetersToPoints(0.75)
.Alignment = wdAlignParagraphLeft
End With
End With
'------------------Zeile 2------------------------------------------------
ActiveDocument.Range(2, 5).Select
With Selection
.Cells.Merge
With .Rows
.HeightRule = wdRowHeightExactly
.Height = CentimetersToPoints(1.8)
End With
With .Cells(1)
.TopPadding = CentimetersToPoints(0.2)
.BottomPadding = CentimetersToPoints(0.2)
.LeftPadding = CentimetersToPoints(0.19)
.RightPadding = CentimetersToPoints(0.19)
.WordWrap = True
.FitText = False
End With
With .Font
.Name = "Arial"
.Size = 10
.Bold = wdToggle
End With
With .ParagraphFormat
.SpaceBeforeAuto = False
.SpaceAfterAuto = False
.LeftIndent = CentimetersToPoints(0.75)
.FirstLineIndent = CentimetersToPoints(0)
.RightIndent = CentimetersToPoints(0.75)
.Alignment = wdAlignParagraphLeft
End With
End With
'------------------Zeile 3------------------------------------------------
ActiveDocument.Range(4, 7).Select
With Selection
.Cells.Merge
With .Rows
.HeightRule = wdRowHeightExactly
.Height = CentimetersToPoints(0.9)
End With
With .Cells(1)
.TopPadding = CentimetersToPoints(0.2)
.BottomPadding = CentimetersToPoints(0.2)
.LeftPadding = CentimetersToPoints(0.19)
.RightPadding = CentimetersToPoints(0.19)
.WordWrap = True
.FitText = False
End With
With .Font
.Name = "Arial"
.Size = 16
.Bold = wdToggle
End With
With .ParagraphFormat
.SpaceBeforeAuto = False
.SpaceAfterAuto = False
.LeftIndent = CentimetersToPoints(0.75)
.FirstLineIndent = CentimetersToPoints(0)
.RightIndent = CentimetersToPoints(0.75)
.Alignment = wdAlignParagraphCenter
End With
End With
'------------------Zeile 4, Zelle 1---------------------------------------
ActiveDocument.Range(6, 6).Select
With Selection
With .Rows
.HeightRule = wdRowHeightExactly
.Height = CentimetersToPoints(0.9)
End With
With .Cells(1)
.TopPadding = CentimetersToPoints(0)
.BottomPadding = CentimetersToPoints(0)
.LeftPadding = CentimetersToPoints(0.05)
.RightPadding = CentimetersToPoints(0.19)
.VerticalAlignment = wdCellAlignVerticalBottom
.WordWrap = True
.FitText = False
End With
With .Font
.Name = "Arial"
.Size = 6
End With
With .ParagraphFormat
.SpaceBeforeAuto = False
.SpaceAfterAuto = False
.LeftIndent = CentimetersToPoints(0.75)
.FirstLineIndent = CentimetersToPoints(-0.75)
.Alignment = wdAlignParagraphLeft
End With
End With
'------------------Zeile 4, Zelle 2---------------------------------------
ActiveDocument.Range(7, 7).Select
With Selection
With .Rows
.HeightRule = wdRowHeightExactly
.Height = CentimetersToPoints(0.9)
End With
With .Cells(1)
.TopPadding = CentimetersToPoints(0)
.BottomPadding = CentimetersToPoints(0)
.LeftPadding = CentimetersToPoints(0.19)
.RightPadding = CentimetersToPoints(0.19)
.VerticalAlignment = wdCellAlignVerticalBottom
.WordWrap = True
.FitText = False
End With
With .Font
.Name = "Arial"
.Size = 16
.Bold = wdToggle
End With
With .ParagraphFormat
.SpaceBeforeAuto = False
.SpaceAfterAuto = False
.Alignment = wdAlignParagraphCenter
End With
End With
'------------------Zeile 4, Zelle 3---------------------------------------
ActiveDocument.Range(8, 8).Select
With Selection
With .Rows
.HeightRule = wdRowHeightExactly
.Height = CentimetersToPoints(0.9)
End With
With .Cells(1)
.TopPadding = CentimetersToPoints(0.15)
.BottomPadding = CentimetersToPoints(0.15)
.LeftPadding = CentimetersToPoints(0.19)
.RightPadding = CentimetersToPoints(0.19)
.WordWrap = True
.FitText = False
End With
With .Font
.Name = "Arial"
.Size = 16
End With
With .ParagraphFormat
.SpaceBeforeAuto = False
.SpaceAfterAuto = False
.RightIndent = CentimetersToPoints(0.75)
.Alignment = wdAlignParagraphRight
End With
End With
'-------------Etikett kopieren und auf dem gesamten Etikettenblatt einfügen--------
ActiveDocument.Range.Cells(1).Select
Selection.Copy
Selection.MoveDown Unit:=wdLine, Count:=1
Selection.PasteAndFormat (wdPasteDefault)
Selection.MoveDown Unit:=wdLine, Count:=1
Selection.PasteAndFormat (wdPasteDefault)
Selection.MoveDown Unit:=wdLine, Count:=1
Selection.PasteAndFormat (wdPasteDefault)
Selection.MoveDown Unit:=wdLine, Count:=1
Selection.PasteAndFormat (wdPasteDefault)
Selection.MoveRight Unit:=wdCharacter, Count:=2
Selection.PasteAndFormat (wdPasteDefault)
Selection.MoveUp Unit:=wdLine, Count:=1
Selection.PasteAndFormat (wdPasteDefault)
Selection.MoveUp Unit:=wdLine, Count:=1
Selection.PasteAndFormat (wdPasteDefault)
Selection.MoveUp Unit:=wdLine, Count:=1
Selection.PasteAndFormat (wdPasteDefault)
Selection.MoveUp Unit:=wdLine, Count:=1
Selection.PasteAndFormat (wdPasteDefault)
End Sub
