AW: Hallo Jowe Hilfe bei Anpassung Tabelle in word
28.07.2023 13:17:30
JoWE
Jörg,
versuch's mal noch mit diesem Code, habe Suchen nach "$" und Ersetzen mit "" eingebaut.
Option Explicit
Sub test()
Dim zeilen As Long
Dim spalten As Long
Dim zeileKurztext As Long
Dim ze As Long
Dim myBMName As String
myBMName = "zusTab"
Dim source As Worksheet
Set source = Sheets("Tabelle1")
Dim myRange As Variant
Set myRange = source.Range("J1:M" & source.Cells(Rows.Count, 13).End(xlUp).Row)
Dim AppWD As Object
Dim WDDoc As Object
Dim WDTable As Object
Set AppWD = CreateObject("Word.Application")
'Anzahl Spalten und Zeilen sowie die Zeile mit dem Kurztext in Excel-Tabelle ermitteln
zeilen = myRange.Rows.Count 'source.Cells(Rows.Count, 10).End(xlUp).Row
spalten = myRange.Columns.Count 'source.Cells(1, Columns.Count).End(xlToLeft).Column - 9
zeileKurztext = zeilen + 3 'source.Cells(Rows.Count, 8).End(xlUp).Row
'Word als Object starten und das Dokument im Hintergrund öffnen
Set WDDoc = AppWD.Documents.Open(ThisWorkbook.Path & "\RECHNUNG BLANK1.docx")
'alle Textmarken im Word-Dokument füllen
With WDDoc
.Bookmarks("Name").Range.Text = source.Cells(2, 1).Value
.Bookmarks("Vorname").Range.Text = source.Cells(2, 2).Value
.Bookmarks("Anrede").Range.Text = source.Cells(2, 6).Value
.Bookmarks("PLZ").Range.Text = source.Cells(2, 4).Value
.Bookmarks("Ort").Range.Text = source.Cells(2, 5).Value
.Bookmarks("Straße").Range.Text = source.Cells(2, 3).Value
.Bookmarks("Rechnungsnummer").Range.Text = source.Cells(2, 9).Value
.Bookmarks("FörmlichesAnsprechen").Range.Text = source.Cells(2, 7).Value
.Bookmarks("Kurztext").Range.Text = source.Cells(zeileKurztext, 8).Value
.Bookmarks("Verordnungsdatum").Range.Text = source.Cells(2, 8).Value
.Bookmarks("Gesamtbetrag").Range.Text = myRange.Cells(zeilen, spalten).Text
.Bookmarks(myBMName).Select 'Cursor an die Position der Textmarke setzen
'die neue Word-Tabelle erstellen an der Position der Textmarke "myBMNAme"
.Tables.Add Range:=AppWD.Selection.Range, NumRows:=zeilen, NumColumns:=spalten
Set WDTable = .Tables(1) 'die neue Tabelle als Object "Table" definieren
End With
With WDTable
'die relevanten Daten aus dem Excel-Tabellenbereich in die Word-TAbelle schreiben
For ze = 1 To zeilen
.cell(ze, 1) = myRange.Cells(ze, 1).Text
.cell(ze, 2) = myRange.Cells(ze, 2).Text
If ze = 1 Then
.cell(ze, 3) = myRange.Cells(ze, 3).Text
.cell(ze, 4) = myRange.Cells(ze, 4).Text
Else
.cell(ze, 3) = CStr(Format(myRange.Cells(ze, 3).Value, "#,##0.00")) & " " & Chr(128)
.cell(ze, 4) = CStr(Format(myRange.Cells(ze, 4).Value, "#,##0.00")) & " " & Chr(128)
End If
Next
.cell(.Rows.Count - 1, 3).Range.Text = ""
.cell(.Rows.Count - 1, 4).Range.Text = ""
'in der Word-Tabelle die Kosmetik durchführen
'für alle Zeilen Zeilenhöhe und vertikale Ausrichtung setzen
.Rows.HeightRule = 2 'wdRowHeightExactly
.Rows.Height = "0.50 cm" 'Zeilenhöhe alle Zeilen
.Rows.Alignment = 1 'wdAlignRowCenter
'Für Spalten entsprechend zum Inhalt Ausrichtung setzen (z.T. links bzw. rechts)
.Columns(1).Select
AppWD.Selection.ParagraphFormat.Alignment = 0 'wdAlignParagraphLeft
.Columns(2).Select
AppWD.Selection.ParagraphFormat.Alignment = 0 'wdAlignParagraphLeft
.Columns(3).Select
AppWD.Selection.ParagraphFormat.Alignment = 2 'wdAlignParagraphRight
.Columns(4).Select
AppWD.Selection.ParagraphFormat.Alignment = 2 'wdAlignParagraphRight
'Für die Zeilen 1 und 6 Schrift von Standard auf auf "Fett" setzen
.Rows(1).Select: AppWD.Selection.Font.Bold = 9999998 'wdToggle
.Rows(6).Select: AppWD.Selection.Font.Bold = 9999998 'wdToggle
'Tabelle Größe an Inhalt ausrichten
.AutoFitBehavior 1 ' 1 = wdAutoFitContent
'Farbe und Style Gitterlinienen
.Range.Font.Size = 10
.Style = "Tabelle mit hellem Gitternetz"
'Tabelle Abstand von links setzen
.Rows.LeftIndent = AppWD.CentimetersToPoints(1)
'Cursor an den Anfang des Dokumentes setzen
End With
'Falls das Währungssymbol statt des "" als "$" angezeigt wurde
With WDDoc
AppWD.Selection.Find.ClearFormatting
AppWD.Selection.Find.Execute Replace:=2 '2 = wdReplaceAll
With AppWD.Selection.Find
.Text = "$"
.Replacement.Text = ""
.Forward = True
.Wrap = 1 '1 = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
AppWD.Selection.Find.Execute Replace:=2 '2 = wdReplaceAll
End With
AppWD.Selection.HomeKey Unit:=6, Extend:=0 '6 = wdStory, 0 = wdMove
'speichern
WDDoc.SaveAs2 ThisWorkbook.Path & "\" & "RGNR_" & [I2].Value & ".docx"
'Excel wieder in Normalzustand versetzen
Application.CutCopyMode = False
Application.ScreenUpdating = True
Application.EnableEvents = True
'der User erhält eine Mitteilung über den erledigten Auftrag
MsgBox "Das Word-Dokument: " & vbCr & vbCr & "Pfad:" & vbCr & _
ThisWorkbook.Path & vbCr & vbCr & "Dateiname:" & vbCr & "RGNR_" _
& [I2].Value & ".docx" & vbCr & vbCr & "wurde erstellt!", vbOKOnly + vbInformation
'Word in den Vordergrund holen
AppWD.Visible = True
AppWD.WindowState = 0 ' wdWindowStateNormal
AppWD.Activate
'Speicher aufräumen
Set myRange = Nothing
Set WDTable = Nothing
Set WDDoc = Nothing
Set AppWD = Nothing
End Sub
Gruß
Jochen