I made a nice Excel file with several (almost the same) macros. Goal is to fill open a Word template, fill in the bookmarks and save every individual document with predefined fields in the filename. Works like a charm... but it doesn't go further then the 10th row of my Excel file. All 12 macros have the same issue, basically the macro is the same only the fields are different.
The VBA I have now is this:
Option Explicit
Sub Akkoordverklaring()
Dim lonLaatsteRij As Long
Dim rngData As Range
Dim strVoornaam As String, strAchternaam As String, strSlber As String
Dim c As Range
With Sheets("Cijferlijst")
lonLaatsteRij = .Cells(Rows.Count, "A").End(xlUp).Row
Set rngData = .Range(.Cells(2, 1), .Cells(lonLaatsteRij, 1))
End With
For Each c In rngData
strVoornaam = c.Value
strAchternaam = c.Offset(0, 1).Value
strSlber = c.Offset(0, 12).Value
Call maakWordDocument(strVoornaam, strAchternaam, strSlber)
Next c
End Sub
Private Sub maakWordDocument(strVoornaam As String, strAchternaam As String, _
strSlber As String)
Dim wordApp As Object, WordDoc As Object
On Error Resume Next
Set wordApp = GetObject("", "Word.Application")
If wordApp Is Nothing Then
Set wordApp = CreateObject("Word.Application")
End If
wordApp.Visible = False
Set WordDoc = wordApp.Documents.Open(ThisWorkbook.Path & _
"Formulieren\Akkoordverklaring.docx")
Call InvullenBladwijzer(wordApp, "voornaam", strVoornaam)
Call InvullenBladwijzer(wordApp, "achternaam", strAchternaam)
Call InvullenBladwijzer(wordApp, "slber", strSlber)
wordApp.DisplayAlerts = False
WordDoc.SaveAs Filename:=ThisWorkbook.Path & _
"Akkoordverklaring\Akkoordverklaring " & strVoornaam & Space(1) & _
strAchternaam, FileFormat:=wdFormatDocumentDefault
WordDoc.Close
wordApp.Quit
Set WordDoc = Nothing
Set wordApp = Nothing
End Sub
Sub InvullenBladwijzer(wordApp As Object, strBladwijzer As String, _
strTekst As String)
wordApp.Selection.Goto What:=wdGoToBookmark, Name:=strBladwijzer
wordApp.Selection.TypeText strTekst
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
End Sub
As I'm not a programmer I just know how to read some VBA. Some users in here also helped me out with the VBA above:
Excel: change VBA action frome same sheet to another sheet
Related
I have modified the code from Macro to export MS Word tables to Excel sheets to copy a sequential interval of tables (e.g. 1 to 4) instead of copying all tables, as in the original code.
But I cannot figure out how to copy a selection of tables in the Word document (e.g. tables 1, 3, 7, 8).
Help to tweak the relevant section of code much appreciated!
'For tableStart = 1 To tableTo '<- copies all tables
For tableStart = 1 To 4 '<- copies sequential interval of tables
With .tables(tableStart)
.Range.Copy
Target.Activate
Target.Parent.PasteSpecial Format:="Text", Link:=False, DisplayAsIcon:=False
'ActiveSheet.Paste <- pastes with formatting
Set Target = Target.Offset(.Rows.Count + 2, 0)
End With
Next tableStart
The entire macro is:
Sub ImportWordTables()
Dim WordApp As Object
Dim WordDoc As Object
Dim arrFileList As Variant, FileName As Variant
Dim tableNo As Integer 'table number in Word
Dim tableStart As Integer
Dim tableTot As Integer
Dim Target As Range
On Error Resume Next
arrFileList = Application.GetOpenFilename("Word files (*.doc; *.docx),*.doc;*.docx", 2, _
"Browse for file containing table to be imported", , True)
If Not IsArray(arrFileList) Then Exit Sub '<-user cancelled import file browser
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = False
Range("A:AZ").ClearContents
Set Target = Worksheets("MySheet").Range("A1")
For Each FileName In arrFileList
Set WordDoc = WordApp.Documents.Open(FileName, ReadOnly:=True)
With WordDoc
tableNo = WordDoc.tables.Count
tableTot = WordDoc.tables.Count
If tableNo = 0 Then
MsgBox WordDoc.Name & "Contains no tables", vbExclamation, "Import Word Table"
End If
'For tableStart = 1 To tableTo '<- copies all tables
For tableStart = 1 To 4 '<- copies interval of tables
With .tables(tableStart)
.Range.Copy
Target.Activate
Target.Parent.PasteSpecial Format:="Text", Link:=False, DisplayAsIcon:=False
'ActiveSheet.Paste <- pastes with formatting
Set Target = Target.Offset(.Rows.Count + 2, 0)
End With
Next tableStart
.Close False
End With
Next FileName
WordApp.Quit
Set WordDoc = Nothing
Set WordApp = Nothing
End Sub
You could supply the list of tables as an array. I added this to the restructured code below. You provide a variant containing an array of the table numbers you want to copy to the ImportWordTables sub. I'll leave it to you to modify the code by making the parameter optional so that you either copy all tables or the tables in the list.
Option Explicit
Public Enum TableImportError
NoTables
UnexpectedIndex
End Enum
Public Sub ImportWordTables(ByVal ipTableList As Variant)
Dim arrFileList As Variant
If Not TryGetFileNameList(arrFileList) Then Exit Sub
Dim WordApp As Object
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = False
' the range should be qualified by the relevant wb/ws
Range("A:AZ").ClearContents
Dim FileName As Variant
For Each FileName In arrFileList
Dim WordDoc As Object
Set WordDoc = WordApp.Documents.Open(FileName, ReadOnly:=True)
Dim myReason As TableImportError
If Not TryImportTables(WordDoc, ipTableList, myReason) Then
Select Case myReason
Case TableImportError.NoTables
MsgBox WordDoc.Name & "Contains no tables", vbExclamation, "Import Word Table"
Case TableImportError.UnexpectedIndex
MsgBox WordDoc.Name & "Unexpected index", vbExclamation, "The table indexes exceed the total table count. No tables copies"
End Select
End If
Next FileName
WordApp.Quit
Set WordDoc = Nothing
Set WordApp = Nothing
End Sub
Private Function TryGetFileNameList(ByRef opFileList As Variant) As Boolean
On Error Resume Next
opFileList = Application.GetOpenFilename("Word files (*.doc; *.docx),*.doc;*.docx", 2, _
"Browse for file containing table to be imported", , True)
On Error GoTo 0
TryGetFileNameList = IsArray(opFileList)
End Function
Private Function TryImportTables(ByRef ipDoc As Word.Document, ByVal ipTableList As Variant, ByRef opReason As TableImportError) As Boolean
TryImportTables = False
If ipDoc.Tables.Count = 0 Then
opReason = TableImportError.NoTables
Exit Function
End If
Dim myTable As Variant
For Each myTable In ipTableList
If myTable > ipDoc.Tables.Count Then
opReason = TableImportError.UnexpectedIndex
Exit Function
End If
Next
For Each myTable In ipTableList
With ipDoc.Tables.Item(myTable)
.Range.Copy
' replaced Target by worksheet refernce
' ideally this item should be passed as a parameter
' or second best defined as a module level variable.
'
' worksheets should be qualified by the relevant wb
With Worksheets("MySheet")
.Activate
.Parent.PasteSpecial Format:="Text", Link:=False, DisplayAsIcon:=False
Set .Range("A1") = .Range("A1").Offset(.Rows.Count + 2, 0)
'.Paste
End With
End With
Next
TryImportTables = True
End Function
The code above compiles and doesn't give any unexpected Code Inspection warning by the free and fantastic Rubberduck addin for VBA. However as its a radical restructuring I can't guarantee it will work exactly as you previous code so please do check if you decide to use it.
Set this code of yours as a Function that you call from the Main Sub with the a TableIndex
With .tables(tableIndex)
.Range.Copy
Target.Activate
Target.Parent.PasteSpecial Format:="Text", Link:=False, DisplayAsIcon:=False
'ActiveSheet.Paste <- pastes with formatting
Set Target = Target.Offset(.Rows.Count + 2, 0)
End With
Set the tableIndex variable as a Random number assigned from the collection of tables in the Word document. You'll have to decide how many times you will iterate thru the code so you get the random sample size you want but the basic code might look like this:
Sub ReturnRandomNumber()
Dim TableIndex As Integer
Dim WordDoc As Word.Document
Randomize
TableIndex = Int((WordDoc.Tables.Count * Rnd) + 1)
CopyRandomTable WordDoc, TableIndex
End Sub
Function CopyRandomTable(ByRef WordDoc As Word.Document, ByRef TableIndex As Integer)
With WordDoc.Tables(TableIndex)
.Range.Copy
Target.Activate
Target.Parent.PasteSpecial Format:="Text", Link:=False, DisplayAsIcon:=False
'ActiveSheet.Paste <- pastes with formatting
Set Target = Target.Offset(.rows.Count + 2, 0)
End With
End Function
The RND function might also return the same table index so you should think about how you might want to deal with that ... like possibly setting up an array of table indexes already used and then act accordingly.
For more information about Randomize and the RND function here is a Microsoft Article on the RND Function.
Solved, but input box and memory capacity issue still to be fixed.
Replace With .tables(tableIndex) section in my first example above with the following:
'For array
Dim tables() As Variant
Dim tableCounter As Long
tables = Array(1, 3, 7) '<- define array manually here
For tableCounter = LBound(tables) To UBound(tables)
With .tables(tables(tableCounter))
.Range.Copy
Target.Activate
'Target.Parent.PasteSpecial Format:="Text", Link:=False, DisplayAsIcon:=False '<- gives RAM capacity problems!
ActiveSheet.Paste '<- pastes with formatting
Set Target = Target.Offset(.Rows.Count + 2, 0)
End With
Next tableCounter
Problem:
I would like to create letters using 2 different letter templates based on a cell value in a column in Excel.
My Question is an extension to the following question:
VBA Automated Mailmerge using 2 templates based on cell value
Example:
In the example below, the value in column C should dictate which letter template will be used for each row. (If cell value is YES use letter template "Yes.docx" otherwise use letter template "No.docx")
Solution proposed by #user3598756 (modified to the above example):
Option Explicit
Sub CommandButton2_Click()
Dim wordApp As Object
Set wordApp = GetWordObject '<--| get a Word object
If wordApp Is Nothing Then Exit Sub '<--| if no Word Object has been gotten then exit sub
With ThisWorkbook.Sheets("Sheet1") '<--| reference your letter worksheet
With Application.Intersect(.UsedRange, Range("A1:C1").EntireColumn) '<--| reference your data range as that in referenced worksheet columns D:H used range
CreateWordDocuments .Cells, "YES", wordApp, "C:\Users\camil\Desktop\YES.docx" '<--| process "YES" documents
CreateWordDocuments .Cells, "NO", wordApp, "C:\Users\camil\Desktop\NO.docx" '<--| process "NO" documents
End With
.AutoFilterMode = False '<--| show all rows back and remove autofilter
End With
'"dispose" Word
wordApp.Quit True '<--| quit Word and save changes to open documents
Set wordApp = Nothing
End Sub
Sub CreateWordDocuments(dataRng As Range, criteria As String, wordApp As Object, templateDocPath As String)
Dim cell As Range
With dataRng '<--| reference data range
.AutoFilter Field:=3, Criteria1:=criteria '<--| filter it on its column 3 with given criteria
If Application.WorksheetFunction.Subtotal(103, .Resize(, 1)) > 1 Then '<--| if any cell has been filtered
For Each cell In .Offset(1).Resize(.Rows.Count - 1, 1).SpecialCells(xlCellTypeVisible) '<--| loop through filtered cells
wordApp.Documents.Add templateDocPath '<-- open the passed Word template
wordApp.Run "Module1.SaveIndividualWordFiles" '<--| run your macro
Next cell
End If
End With
End Sub
Function GetWordObject() As Object
Dim wordApp As Object
On Error Resume Next
Set wordApp = GetObject(, "Word.Application") '<--| try getting a running Word application
On Error GoTo 0
If wordApp Is Nothing Then Set wordApp = CreateObject("Word.Application") '<--| if no running instance of Word has been found then open a new one
Set GetWordObject = wordApp '<--| return the set Word application
wordApp.Visible = False
End Function
Request:
Unfortunately, the original poster of the question didn't share his "SaveIndividualWordFiles" macro.
I tried to fill in the gap with parts of the VBA I usually use to mailmerge from Word, when I only have one letter template. (Seen below)
However I can't fit the pieces together.
Sub Merge_To_Individual_Files()
Application.ScreenUpdating = False
Dim StrFolder As String, StrName As String, MainDoc As Document, i As Long, j As Long
Const StrNoChr As String = """*./\:?|"
Set MainDoc = ActiveDocument
With MainDoc
StrFolder = .Path & Application.PathSeparator
For i = 1 To .MailMerge.DataSource.RecordCount
With .MailMerge
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .DataSource
.FirstRecord = i
.LastRecord = i
.ActiveRecord = i
If Trim(.DataFields("Col A")) = "" Then Exit For
StrName = .DataFields("Col A") & " " & .DataFields("Col C")
End With
.Execute Pause:=False
If Err.Number = 5631 Then
Err.Clear
GoTo NextRecord
End If
End With
For j = 1 To Len(StrNoChr)
StrName = Replace(StrName, Mid(StrNoChr, j, 1), "_")
Next
StrName = Trim(StrName)
With ActiveDocument
.SaveAs FileName:=StrFolder & StrName & ".docx", FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
.SaveAs FileName:=StrFolder & StrName & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
.Close SaveChanges:=False
End With
NextRecord:
Next i
End With
Application.ScreenUpdating = False
End Sub
Any help is appreciated.
Data dynamically populating from drop-down list correctly; however, how may I get the Word document to close properly in between each entry?
Problem:
The Word document doesn't close properly in between each new entry in the Excel dynamic drop-down list.
What is occurring:
The loop is executing over each hospital; however, Word isn't closing in between each new entity. Result is that all the addresses and tables are inserting without interruption.
What should occur:
Each hospital with it's own unique data in a new Word document (attached, the Excel sheet "Table" has a drop-down in call B2 that autopopulates the table 1 and the hospital's address; the Word document has bookmarks to insert this data).
In advance, thank you very much for your expertise. I have tried various commands to close the active document in Word (not shown) but then cannot get Word to open up again with the template. Realize there is likely a simple solution to incorporate into the existing code.
Regards,
Karen
Sub MMISPMT()
Worksheets("table").Activate
'Declare variables
Dim WordApp As Object
Dim WordDoc As Object
Dim dvCell As Range
Dim inputRange As Range
Dim c As Range
ActiveWindow.View = xlNormalView
'Set variables
'Which cell has data validation
Set dvCell = Worksheets("Table").Range("B2") 'this is a drop-down box of entity name values that
populates address info and table 1 in Word document
'Determine where validation comes from
Set inputRange = Evaluate(dvCell.Validation.Formula1)
Set WordApp = New Word.Application ' based on the template ref'd in WordDoc
'Word template to be used
Set WordDoc = WordApp.Documents.Add(Template:="C:\<pathway>\letter.docx", NewTemplate:=False,
DocumentType:=0)
'Begin loop
Application.ScreenUpdating = False
For Each c In inputRange
dvCell = c.Value
MsgBox dvCell
Debug.Print dvCell
Dim table1 As Range
Dim HosName As Range
Dim address1 As Range
Dim city As Range
Dim zip As Range
'Declare variables
Set table1 = Range("a10:g15")
Set HosName = Range("b2")
Set address1 = Range("ad5")
Set city = Range("ad6")
Set zip = Range("ad7")
HosName.Select
Selection.Copy
WordApp.Visible = True
WordApp.ActiveDocument.Bookmarks("HosName").Select
Set objSelection = WordApp.Selection
objSelection.PasteSpecial DataType:=wdPasteText
address1.Select
Selection.Copy
WordApp.Visible = True
WordApp.ActiveDocument.Bookmarks("address1").Select
Set objSelection = WordApp.Selection
objSelection.PasteSpecial DataType:=wdPasteText
city.Select
Selection.Copy
WordApp.Visible = True
WordApp.ActiveDocument.Bookmarks("city").Select
Set objSelection = WordApp.Selection
objSelection.PasteSpecial DataType:=wdPasteText
zip.Select
Selection.Copy
WordApp.Visible = True
WordApp.ActiveDocument.Bookmarks("zip").Select
Set objSelection = WordApp.Selection
objSelection.PasteSpecial DataType:=wdPasteText
table1.Select
Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
WordApp.Visible = True
WordApp.ActiveDocument.Bookmarks("table1").Select
Set objSelection = WordApp.Selection
objSelection.Paste
'Generate the Word template per hospital with data
WordApp.ActiveDocument.SaveAs2 Filename:="C:\<pathway>\" & HosName & " " & Format((Year(Now() + 1)
Mod 100), "20##") & _
Format((Month(Now() + 1) Mod 100), "0#") & _
Format((Day(Now()) Mod 100), "0#") & "-report.docx", _
FileFormat:=wdFormatXMLDocument
Next c
Application.ScreenUpdating = True
End Sub
You need to open the template at the top of the loop, then save and close the document at the bottom of the loop.
Also you can tidy up your code by factoring the copy/paste into a separate method.
Sub MMISPMT()
Dim WordApp As Object
Dim WordDoc As Object
Dim dvCell As Range
Dim inputRange As Range
Dim c As Range, wsTable As Worksheet
Set wsTable = Worksheets("Table")
Set dvCell = Worksheets("Table").Range("B2")
Set inputRange = Evaluate(dvCell.Validation.Formula1)
Set WordApp = New Word.Application ' based on the template ref'd in WordDoc
For Each c In inputRange.Cells
Set WordDoc = WordApp.Documents.Add(Template:="C:\<pathway>\letter.docx", _
NewTemplate:=False, DocumentType:=0)
dvCell = c.Value
CopyToBookmark wsTable.Range("B2"), WordDoc, "HosName"
CopyToBookmark wsTable.Range("AD5"), WordDoc, "address1"
CopyToBookmark wsTable.Range("AD6"), WordDoc, "city"
CopyToBookmark wsTable.Range("AD7"), WordDoc, "zip"
CopyToBookmark wsTable.Range("A10:G15"), WordDoc, "table1", False
WordDoc.SaveAs2 Filename:="C:\<pathway>\" & HosName & " " & _
Format((Year(Now() + 1) Mod 100), "20##") & _
Format((Month(Now() + 1) Mod 100), "0#") & _
Format((Day(Now()) Mod 100), "0#") & "-report.docx", _
FileFormat:=wdFormatXMLDocument
WordDoc.Close
Next c
End Sub
'transfer/copy data from a Range into a named bookmark in doc
' either directly as text or copy/paste as table
Sub CopyToBookmark(rng As Range, doc As Word.document, bmk As String, _
Optional AsValue As Boolean = True)
If AsValue Then
doc.bookmarks(bmk).Range.Text = rng.Value
Else
rng.Copy
doc.bookmarks(bmk).Range.Paste
End If
End Sub
I am trying to loop through a number of word documents in a folder, and add some information from the word tables to the excel sheet. Right now I have this:
Private Sub Loop_WordToExcel()
Dim WdApp As Object
Dim wddoc As Object
Dim docName As String
Dim strFile As String
Dim directory As String
directory = "c:\path\to\folder"
strFile = Dir(directory & "*.*")
Set WdApp = CreateObject("Word.Application")
Dim rng As Range
Set rng = Application.InputBox(Prompt:="Enter row", Type:=8)
'Do While strFile <> ""
Set wddoc = WdApp.Documents.Open(Filename:=directory & strFile)
rng.Cells(1) = wddoc.Name
'First Name
wddoc.Tables(1).Cell(1, 3).Range.Copy
rng.Cells(2).PasteSpecial (xlPasteValues)
WdApp.ActiveDocument.Close SaveChanges:=False
strFile = Dir
Loop
End Sub
I have two questions.
1. My first issue is a Run-time error '1004': PasteSpecial method of Range class failed
2. At the end of the loop, how to I advance to the next row for the next word document information to be pasted.
Correct syntax while copying from Word is given, May try
Sub Loop_WordToExcel()
Dim WdApp As Word.Application
Dim WdDoc As Document
Dim docName As String
Dim strFile As String
Dim directory As String
Dim Rng As Range
Dim Offst As Long, Txt As String
directory = "C:\users\user\Desktop\Folder1\" ' Change to your path
strFile = Dir(directory & "*.docx") ' docx extension added to prevent attempt to open other type of files
Set Rng = Application.InputBox(Prompt:="Enter row", Type:=8) '
Set WdApp = CreateObject("Word.Application")
WdApp.Visible = True
Do While strFile <> ""
Set WdDoc = WdApp.Documents.Open(Filename:=directory & strFile)
Rng.Offset(Offst, 0).Value = WdDoc.Name
'First Name
WdDoc.Tables(1).Cell(1, 3).Range.Copy 'will raise error if table& corres cell not exists , My use error handrel
Rng.Offset(Offst, 1).Activate
ActiveSheet.PasteSpecial Format:="Text", Link:=False, DisplayAsIcon:=False 'Assumed want get name in Column B
'is is suggested to use the below two lines instead of paste special above three lines
'Txt = WdDoc.Tables(1).Cell(1, 3).Range.Text 'will raise error if table& corres cell not exists , My use error handrel
'Rng.Offset(Offst, 1).Value = Txt
WdDoc.Close SaveChanges:=False
Offst = Offst + 1
strFile = Dir
Loop
WdApp.Quit
End Sub
It is always preferred to add reference of Microsoft Word Object library.
As I'm trying my first Excel with macro's I could really use some help. I'm not a programmer but I can edit some code very well.
My goal is to generate some different word documents by the click of a button. The excel file is a list with achievements of students. The results are listed in the different word documents. It's kind of a mail merge but without opening Word.
The code I have now is for a button in the same sheet to generate those word documents. Now I changed the whole excel file...and I'm lost with the VBA.
I know it has something to do with:
Sub Selecteren_Cijferlijst()
' Selecteren_Cijferlijst Macro
Sheets("Cijferlijst").Select
End Sub
The code I got from a kind user on a forum is this:
Option Explicit
Sub Vooraanmelding()
Dim lonLaatsteRij As Long
Dim rngData As Range
Dim strGeboortedatum As String, strStudentnummer As String, strVoornaam As String, strAchternaam As String, strAdres As String, strPostcode As String, strWoonplaats As String, strTelefoon As String, strEmail As String, strCrebo As String, strKlas As String, strProfiel As String, strSlber As String
Dim c As Range
With ActiveSheet
'bepaal de onderste rij van het actieve excel-werkblad
lonLaatsteRij = .Cells(Rows.Count, "A").End(xlUp).Row
'stel bereik in
Set rngData = .Range(.Cells(2, 1), .Cells(lonLaatsteRij, 1))
End With
For Each c In rngData
c.Select
strGeboortedatum = c.Offset(0, 7).Value
strStudentnummer = c.Offset(0, 2).Value
strVoornaam = c.Value
strAchternaam = c.Offset(0, 1).Value
strAdres = c.Offset(0, 4).Value
strPostcode = c.Offset(0, 5).Value
strWoonplaats = c.Offset(0, 6).Value
strTelefoon = c.Offset(0, 8).Value
strEmail = c.Offset(0, 9).Value
strCrebo = c.Offset(0, 10).Value
strKlas = c.Offset(0, 3).Value
strProfiel = c.Offset(0, 11).Value
strSlber = c.Offset(0, 12).Value
Call maakWordDocument(strGeboortedatum, strStudentnummer, strVoornaam,
strAchternaam, strAdres, strPostcode, strWoonplaats, strTelefoon, strEmail,
strCrebo, strKlas, strProfiel, strSlber)
Next c
End Sub
Private Sub maakWordDocument(strGeboortedatum As String, strStudentnummer As String, strVoornaam As String, strAchternaam As String, strAdres As String, strPostcode As String, strWoonplaats As String, strTelefoon As String, strEmail As String, strCrebo As String, strKlas As String, strProfiel As String, strSlber As String)
'maak een verwijzing naar de Microsoft Word 16.0 Object Library!!
Dim wordApp As Object, WordDoc As Object
On Error Resume Next
'kijk of word al open staat
Set wordApp = GetObject(, "Word.Application")
'open word
If wordApp Is Nothing Then
'If Not open, open Word Application
Set wordApp = CreateObject("Word.Application")
End If
'toon word (of niet, dan op false)
wordApp.Visible = False
'open het 'bron'-bestand
Set WordDoc = wordApp.Documents.Open(ThisWorkbook.Path & "Vooraanmelding\Vooraanmelding.docx")
'bladwijzers invullen
Call InvullenBladwijzer(wordApp, "geboortedatum", strGeboortedatum)
Call InvullenBladwijzer(wordApp, "studentnummer", strStudentnummer)
Call InvullenBladwijzer(wordApp, "voornaam", strVoornaam)
Call InvullenBladwijzer(wordApp, "achternaam", strAchternaam)
Call InvullenBladwijzer(wordApp, "adres", strAdres)
Call InvullenBladwijzer(wordApp, "postcode", strPostcode)
Call InvullenBladwijzer(wordApp, "woonplaats", strWoonplaats)
Call InvullenBladwijzer(wordApp, "telefoon", strTelefoon)
Call InvullenBladwijzer(wordApp, "email", strEmail)
Call InvullenBladwijzer(wordApp, "crebo", strCrebo)
Call InvullenBladwijzer(wordApp, "klas", strKlas)
Call InvullenBladwijzer(wordApp, "profiel", strProfiel)
Call InvullenBladwijzer(wordApp, "slber", strSlber)
'bestand opslaan en alles netjes afsluiten
wordApp.DisplayAlerts = False
WordDoc.SaveAs Filename:=ThisWorkbook.Path & "Vooraanmelding\Vooraanmelding " & strVoornaam & Space(1) & strAchternaam, FileFormat:=wdFormatDocument
WordDoc.Close
wordApp.Quit
Set WordDoc = Nothing
Set wordApp = Nothing
wordApp.DisplayAlerts = True
On Error GoTo 0
End Sub
Sub InvullenBladwijzer(wordApp As Object, strBladwijzer As String, strTekst As String)
'tekst invullen in relevante strBladwijzer
wordApp.Selection.Goto What:=wdGoToBookmark, Name:=strBladwijzer
wordApp.Selection.TypeText strTekst
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
End Sub
This code is what someone gave me, it was a quick 'n' dirty solution for the file I had. Now I changed the setup of my excel so my colleagues also can work with it. That's why I decided to put all buttons on a separate sheet.
You need to directly qualify your range rngData with a sheet and not rely on ActiveSheet.
Delete first sub and link buttons to Sub Vooraanmelding
With Sheets("Cijferlijst")
lonLaatsteRij = .Cells(Rows.Count, "A").End(xlUp).Row
Set rngData = .Range(.Cells(2, 1), .Cells(lonLaatsteRij, 1))
End With