Excel Data to Word Template

[Franztestet]

Hi,

I would like to run a Word Template with a range of excel data. It should copy the data to word if the cell in A is the same then cell d1 and that criteria for every line in the excel table. After that it should save the word with a name which is in cell b (for every single line).

This is how my code looks right now. It somehow doesn't work and i have no ide what to change.

Option Explicit



Sub zwanzigsterzehnter()



Dim wd As Object

Dim wdDOC As Object

Dim iRow As Long

Dim PercentageScore As Variant

Dim sh As Worksheet

Dim myValue As Variant

Dim WorkOrder As String

Dim wdgotobookmark As Object



'aus Excel Sheet „Overview“ ab Feld B8

WorkOrder = Worksheets("Overview").Range("B8").Value



'ab Spalte 8

Set sh = ThisWorkbook.Sheets("Overview")

iRow = 8 'row in which data starts from in database



Do While sh.Range("A" & iRow).Value <> "" 'alle Zeilen die nicht leer sind und Zelle A gleich Wert in D1 entspricht

If WorkOrder = sh.Range("D1" & iRow).Value Then



'Word Vorlage öffnen

Set wdDOC = wd.Documents.Add("C:\Pfad\Vorlage.docx")



‚Word sichtbar lassen

wd.Visible = True



'Textmarken in Word einfügen



wd.Selection.GoTo what:=wdgotobookmark, NAME:="DN"

wd.Selection.TypeText Text:=sh.Range("B" & iRow).Value



wd.Selection.GoTo what:=wdgotobookmark, NAME:="DNa"

wd.Selection.TypeText Text:=sh.Range("C" & iRow).Value





'Word mit neuem Namen aus Zeile B1 speichern



ActiveDocument.SaveAs2 (ThisWorkbook.Path & "C:\Pfad\" & sh.Range("B1" & iRow).Value & ".docx")



Exit Do



End If



iRow = iRow + 1



Loop



MsgBox ("Word Vorlage erstellt")



End Sub

Thanks for your help!

 

[NdNoviceHlp]

You need to create an instance of Word before using it to open your document...

'open Word application
On Error Resume Next
Set Wd = GetObject(, "word.application")
If Err.Number <> 0 Then
On Error GoTo 0
Set Wd = CreateObject("Word.Application")
End If
On Error GoTo 0

Place this code before the Do loop. HTH. Dave

 

[Franztestet]

Hi Dave,

Thanks for your fast reply. I put the code after the 'do while (...) If workorder (...) Then
Your code

Excel shows that it created the word file but it didn't.


Thanks and sorry for those questions.

Best regards

 

[Franztestet]

this is how my code looks right now

Sub zwanzigsterzehnter()
 
Dim wd As Object
Dim wdDOC As Object
Dim iRow As Long
Dim PercentageScore As Variant
Dim sh As Worksheet
Dim myValue As Variant
Dim WorkOrder As String
Dim wdgotobookmark As Object
 
'aus Excel Sheet  "Overview" ab Feld B8
WorkOrder = Worksheets("Overview").Range("B2").Value
 
'ab Spalte 8
Set sh = ThisWorkbook.Sheets("Overview")
iRow = 2 'row in which data starts from in database

Do While sh.Range("A" & iRow).Value <> ""  'alle Zeilen die nicht leer sind und Zelle A gleich Wert in D1 entspricht
    If WorkOrder = sh.Range("E1" & iRow).Value Then 'condition
 
 'open Word application
On Error Resume Next
Set wd = GetObject(, "word.application")
If Err.Number <> 0 Then
On Error GoTo 0
Set wd = CreateObject("Word.Application")
End If
On Error GoTo 0

'Word Vorlage öffnen
Set wdDOC = wd.Documents.Add("C:\Users\Test.docx")

'Word sichtbar lassen
wd.Visible = True
 
'Textmarken in Word einfügen

wd.Selection.GoTo what:=wdgotobookmark, Name:="Name"
wd.Selection.TypeText Text:=sh.Range("B" & iRow).Value

'Word mit neuem Namen aus Zeile B1 speichern
 
wdDOC.SaveAs2 (ThisWorkbook.Path & "C:\Users" & sh.Range("B" & iRow).Value & ".docx")
 
Exit Do
 
End If
 
iRow = iRow + 1
 
Loop
 
MsgBox ("Word document created")
 
End Sub

 

[NdNoviceHlp]

"Place this code before the Do loop" U only need to create 1 instance of Word outside the Do loop ie BEFORE the Do. Dave
ps. U will need to use the task manager to kill the Word process(S) that U created and never used. Also U need to open the document not add it....

Wd.Documents.Open Filename:="C:\Pfad\Vorlage.docx"

 

[Franztestet]

Hi Dave,

and sorry to bother you again. I have no idea how to fix that, word is opening now but nothing is happening. im not able to fill the bookmarks in Word with my table from excel. can i post my current code again?

i added those lines before the DO

Set objword = CreateObject("word.application")
objword.Visible = True

objword.documents.Open ("C:\Pfad\Test.docx")


thanks and best regards

 

[NdNoviceHlp]

Hi Franztestet. Working with Word from XL can result in hair loss if U haven't already noticed A few questions: Does the bookmark exist in the document? Are U trying to use the document as a template? Are U trying to insert a table at the bookmark or just insert a value? Dave

 

[Franztestet]

Hi Franztestet. Working with Word from XL can result in hair loss if U haven't already noticed A few questions: Does the bookmark exist in the document? Are U trying to use the document as a template? Are U trying to insert a table at the bookmark or just insert a value? Dave

Hi Dave,
i already noticed that :/. And i am a completely beginner in VBA.
- the bookmark exists in the word document
- i try to use the word as a template
- it should insert only the value

best regards

 

[NdNoviceHlp]

You can trial this BUT U need to save your "C:\Users\Test.docx" file as a template document which will have a .dot file extension. HTH. Dave

Sub zwanzigsterzehnter()
Dim wd As Object
Dim wdDOC As Object
Dim iRow As Long
Dim PercentageScore As Variant
Dim sh As Worksheet
Dim myValue As Variant
Dim WorkOrder As String
Dim wdgotobookmark As Object
 
'open Word application
On Error Resume Next
Set wd = GetObject(, "word.application")
If Err.Number <> 0 Then
On Error GoTo 0
Set wd = CreateObject("Word.Application")
End If

'ab Spalte 8
Set sh = ThisWorkbook.Sheets("Overview")
iRow = 2 'row in which data starts from in database
'aus Excel Sheet  "Overview" ab Feld B8
WorkOrder = CSTR(Worksheets("Overview").Range("B2").Value)

Do While sh.Range("A" & iRow).Value <> ""  'alle Zeilen die nicht leer sind und Zelle A gleich Wert in D1 entspricht
If WorkOrder = CStr(sh.Range("E1" & iRow).Value) Then 'condition
 'Word Vorlage öffnen
'Set wdDOC = wd.Documents.Add("C:\Users\Test.docx")
Set wdDOC = wd.Documents.Add(Template:="C:\Users\Test.dot", NewTemplate:=False, DocumentType:=0)
'Word sichtbar lassen
wd.Visible = True
 'Textmarken in Word einfügen
With wdDOC
If .Bookmarks.Exists("Name") = True Then
.Goto what:=wdgotobookmark, Name:="Name"
.TypeText WorkOrder 'Text:=CStr(sh.Range("B" & iRow).Value)
Else
MsgBox "No bookmark"
End If
End With
'Word mit neuem Namen aus Zeile B1 speichern
wdDOC.SaveAs2 (ThisWorkbook.Path & "C:\Users" & CStr(sh.Range("B" & iRow).Value) & ".docx")
Exit Do
End If
iRow = iRow + 1
Loop

MsgBox ("Word document created")
 
End Sub

 

[Franztestet]

again there is nothing happening and i need to kill all word processes with task manager.
i have no idea what i need to change at that point. i try to get back to that tomorrow.
thanks