Wordtabelle dynam. aus Excel

Sub Macro_RV1() Dim AppWD As Object Weg = "\\xxx\dfs\xxx\xxx\xxx\__MAKROS_NEU" Auswahl_Datei = "2021-07-01 # Muster Vertrag.docm" Dateiname = ActiveWorkbook.FullName AnzahlDateiname = Len(Dateiname) - 5 Dateiname = Left(Dateiname, AnzahlDateiname) & "_RV" Set AppWD = CreateObject("word.application") With AppWD .Documents.Open (Weg & "/" & Auswahl_Datei), ReadOnly:=True .Visible = True .Activate .Selection.GoTo What:=wdGoToBookmark, Name:="VLRTab" Stop .Range.Collapse 0 .Range.InsertParagraphAfter Set rng = .Paragraphs.Add(.Paragraphs(.Paragraphs.Count).Range) .Tables.Add Range:=rng.Range, NumRows:=2, NumColumns:=2 With .Tables(.Tables.Count) .Borders.Enable = True .Cell(1, 1).Range.Text = "Klasse" .Cell(1, 2).Range.Text = "Beitragssatz" .Rows(1).Range.Font.Bold = True .Columns(1).Width = 75 .Columns(2).Width = 75 End With ActiveDocument.SaveAs2 Filename:= _ Dateiname, FileFormat:= _ wdFormatXMLDocument, LockComments:=False, Password:="", AddToRecentFiles _ :=True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts _ :=False, SaveNativePictureFormat:=False, SaveFormsData:=False, _ SaveAsAOCELetter:=False, CompatibilityMode:=15 .Visible = True .Activate End With Set AppWD = Nothing End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit '********************************************ACHTUNG!**************************** '**********Verweis auf Microsoft Word Obkect Library gesetzt?**************** Sub Macro_RV1() Dim AppWD As Object Dim wdDoc As Object Dim Rng As Object Dim weg As String Dim wdAuswahl_Dazei As String Dim Dateiname As String Dim Auswahl_Datei As String Dim AnzahlDateiname As Long weg = "\\xxx\dfs\xxx\xxx\xxx\__MAKROS_NEU" Auswahl_Datei = "2021-07-01 # Muster Vertrag.docm" Dateiname = ActiveWorkbook.Name AnzahlDateiname = Len(Dateiname) - 5 Dateiname = Left(Dateiname, AnzahlDateiname) & "_RV" Set AppWD = CreateObject("word.application") AppWD.Documents.Open (weg & "/" & Auswahl_Datei), ReadOnly:=True Set wdDoc = AppWD.ActiveDocument With wdDoc .Bookmarks("VLRTab").Range.Text = Sheets(1).Cells(1, 18).Value .Range.Collapse 0 .Range.InsertParagraphAfter Set Rng = .Paragraphs.Add(.Paragraphs(.Paragraphs.Count).Range) .Tables.Add Range:=Rng.Range, NumRows:=3, NumColumns:=2 With .Tables(.Tables.Count) .Borders.Enable = True .Cell(1, 1).Range.Text = "Klasse" .Cell(1, 2).Range.Text = "Beitragssatz" .Rows(1).Range.Font.Bold = True .Columns(1).Width = 75 .Columns(2).Width = 75 End With .SaveAs2 Filename:=weg & "\" & Dateiname & ".docx", FileFormat:= _ wdFormatXMLDocument, LockComments:=False, Password:="", AddToRecentFiles _ :=True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts _ :=False, SaveNativePictureFormat:=False, SaveFormsData:=False, _ SaveAsAOCELetter:=False, CompatibilityMode:=15 End With AppWD.Visible = True AppWD.Activate Set wdDoc = Nothing Set AppWD = Nothing End Sub

Set AppWD = CreateObject("word.application") AppWD.Documents.Open (weg & "/" & Auswahl_Datei), ReadOnly:=True For Each Zelle In Bereich 'Bereich der Staffelübersicht ermittelt? If (Zelle.Value) = Eingabe Then Range("L1:M" & (Zelle.Row)).CopyPicture End If With AppWD.Selection .Goto What:=wdGoToBookmark, Name:="VLRTab" .Paste End With Next Zelle

Hi Jochen klappt so 1A! Danke. Darf ich nochmal um Hilfe bitten?
An der definierten Textmarke füge ich jetzt eine andere Tabelle nach deinem Code ein. Jetzt müsste ich allerdings in Abhängigkeit der Anzahl der Kunden die Zeile mehrfach erstellen und den Kunden Namen entsprechend austauschen. Habe ich 1 Kunden, dann nur einmal die Unterschriftzeile, habe ich 3 dann 3mal die Zeile wobei der Kundennamen variiert. Dieser kommt aus dem Tabellenblatt Adressen. Wie kann man das am besten anstellen?
Für die Tabelle habe ich den Code zusammengestellt. Bei einem Kunden ideal. Bei mehreren fehlt mir im Moment das nötige Wissen wie ich die Schleife (in Abhängigkeit der Anzahl Kunden vom Blatt Adressen) und den geänderten Kundennamen (vom Blatt Adressen) einbaue.
Mein Versuch, wobei mir wie geschrieben die Schleife fehlt.


.Bookmarks("Unterschriften").Range.Text = Sheets(1).Cells(1, 18).Value
.Range.Collapse 0
.Range.InsertParagraphAfter
Set Rng = .Paragraphs.Add(.Paragraphs(.Paragraphs.Count).Range)
.Tables.Add Range:=Rng.Range, NumRows:=(AnzVN), NumColumns:=3
With .Tables(.Tables.Count)
.Borders.Enable = False
.Columns(1).Width = 150
.Columns(2).Width = 75
.Columns(3).Width = 250
.rows(1).SetHeight 50, wdRowHeightExactly
.Cell(1, 1).Range.Text = "Ort, Datum"
.Cell(1, 1).VerticalAlignment = wdCellAlignVerticalTop
.Cell(1, 1).Borders(wdBorderTop).LineStyle = xlContinuous
.Cell(1, 3).Range.Text = "Stempel/Unterschrift  " & NameVN
.Cell(1, 3).VerticalAlignment = wdCellAlignVerticalTop
.Cell(1, 3).Borders(wdBorderTop).LineStyle = xlContinuous
.rows(1).Range.Font.Size = 8
.rows(1).Range.Font.Name = "Arial"
End With

Weiteroben ermittle ich die Anzahl VN so:


Dim ZelleVN As Range
Dim BereichVN As Range
Set T5 = Worksheets("Adressen")
Set BereichVN = T5.Range("A6:A" & Cells(rows.Count, 1).End(xlUp).Row) 'Suche bis letzte gefüllte Zelle in Spalte A
AnzVN = 0
For Each ZelleVN In BereichVN           'Anzahl VN ermitteln
If (ZelleVN.Value)  "" Then
AnzVN = AnzVN + 1
End If
Next ZelleVN

Der Kundenname wird so ermittelt:


NameVN = T5.Cells(6, 5).Value & " " & T5.Cells(6, 6).Value

AppWD.Selection.InlineShapes.AddPicture Filename:="DeinPfad\DeinBild.jpg" 'oder vielleicht besser an eine weitere Textmarke setzen: '.Bookmarks("picPos").Range.InlineShapes.AddPicture Filename:="Dein Pfad\Dein_Bild.jpg"

Beliebteste Forumthreads (12 Monate)

13 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

13
Beiträge zum Forumthread

Beiträge zu diesem Forumthread