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
Related
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.
I have two sheets. One is template, another one is a list. I managed to build a code to auto-populate the list based on data from the template using an offset function. The last bit of the script contains an error. What I wanted to achieve was to create a new workbook from the template and save under a name you can type in a window, hence InputBox function.
Just for reference the template is "NCR ACTION RECORD"
the list is "Data"
Sub Macro()
Dim strNCRReference As String, strType As String
Dim strOpenDate As String, strSupplierName As String
Dim strPartNo As String, Qty As Integer
Dim wb As Workbook
Dim wbName As String
Worksheets("NCR ACTION RECORD").Activate
strNCRReference = Range("A4")
strType = Range("B4")
strOpenDate = Range("C4")
strSupplierName = Range("F4")
strPartNo = Range("G4")
Qty = Range("H4")
Worksheets("Data").Activate
Range("A1").Activate
Do
If ActiveCell.Value = "" Then Exit Do
ActiveCell.Offset(1, 0).Activate
Loop
ActiveCell.Value = strNCRReference
ActiveCell.Offset(0, 3).Value = strType
ActiveCell.Offset(0, 1).Value = strOpenDate
ActiveCell.Offset(0, 6).Value = strSupplierName
ActiveCell.Offset(0, 8).Value = strPartNo
ActiveCell.Offset(0, 10).Value = Qty
Worksheets("NCR ACTION RECORD").Activate
Set wb = Workbook.Add
ThisWorkbook.Activate
ThisWorkbook.Sheets("NCR ACTION RECORD").Copy Before:=wb.Sheets(1)
wb.Activate
wbName = InputBox("Enter a name of a new sheet")
wb.SaveAs "C:\Users\S7051895\Desktop\wbName.xlsx"
End Sub
The error is Run-time error '424'
Object required.
you did some typo in your code :
1 : Workbooks.Add and not Workbook.Add
2 : wb.SaveAs "C:\Users\S7051895\Desktop\" & wbName & ".xlsx" and not wb.SaveAs "C:\Users\S7051895\Desktop\wbName.xlsx"
So your code would be like that
Sub Macro()
Dim strNCRReference As String, strType As String
Dim strOpenDate As String, strSupplierName As String
Dim strPartNo As String, Qty As Integer
Dim wb As Workbook
Dim wbName As String
If ActiveSheet.Name <> "NCR ACTION RECORD" Then Worksheets("NCR ACTION RECORD").Activate
strNCRReference = Range("A4")
strType = Range("B4")
strOpenDate = Range("C4")
strSupplierName = Range("F4")
strPartNo = Range("G4")
Qty = Range("H4")
Worksheets("Data").Activate
Range("A1").Activate
Do
If ActiveCell.Value = "" Then Exit Do
ActiveCell.Offset(1, 0).Activate
Loop
ActiveCell.Value = strNCRReference
ActiveCell.Offset(0, 3).Value = strType
ActiveCell.Offset(0, 1).Value = strOpenDate
ActiveCell.Offset(0, 6).Value = strSupplierName
ActiveCell.Offset(0, 8).Value = strPartNo
ActiveCell.Offset(0, 10).Value = Qty
Worksheets("NCR ACTION RECORD").Activate
Set wb = Workbooks.Add
ThisWorkbook.Activate
ThisWorkbook.Sheets("NCR ACTION RECORD").Copy Before:=wb.Sheets(1)
wb.Activate
wbName = InputBox("Enter a name of a new sheet")
wb.SaveAs "C:\Users\S7051895\Desktop\" & wbName & ".xlsx"
End Sub
It's Workbooks.Add, not Workbook.Add. Trying to use the latter in a test-sub on my computer, I get an error "Variable not defined" on the line containing that code, I assume the reason you get a different error is because the workbook-object has not been set when you attempt to interact with it later in the code.
As an additional comment on your code, I would advice you to use
With Worksheets("NCR ACTION RECORD")
strNCRReference = .Range("A4")
...
End With
instead of Worksheets("NCR ACTION RECORD").Activate and then doing actions on that sheet. The former is much more robust, in addition to being faster code to execute.
The code below is a web page table scraper that I am using and it works nicely. It currently only opens the hyperlink that is in location 'L4' using .Open "GET", Range("L4"), False
Sub ImportData()
'Objects
Dim htm As Object
Dim Tr As Object
Dim Td As Object
Dim Tab1 As Object
'Create HTMLFile Object
Set HTML_Content = CreateObject("htmlfile")
'Get the WebPage Content to HTMLFile Object
On Error GoTo Error
With CreateObject("msxml2.xmlhttp")
.Open "GET", Range("L4"), False 'Cell that contains hyperlink
.send
HTML_Content.body.innerHTML = .responseText
End With
On Error GoTo Error
'Add New Worksheet
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets.Add(After:= _
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
ws.Name = "ESTIMATE"
'Set table variables
Column_Num_To_Start = 1
iRow = 2
iCol = Column_Num_To_Start
iTable = 0
'Loop Through Each Table and Download it to Excel in Proper Format
For Each Tab1 In HTML_Content.getElementsByTagName("table")
With HTML_Content.getElementsByTagName("table")(iTable)
For Each Tr In .Rows
For Each Td In Tr.Cells
Sheets(2).Cells(iRow, iCol).Select
Sheets(2).Cells(iRow, iCol) = Td.innerText
iCol = iCol + 1
Next Td
iCol = Column_Num_To_Start
iRow = iRow + 1
Next Tr
End With
iTable = iTable + 1
iCol = Column_Num_To_Start
iRow = iRow + 1
Next Tab1
'Success
'Loop to find authorised hours string
Dim rng1 As Range
Dim strSearch As String
strSearch = "Hours"
Set rng1 = Range("A:A").Find(strSearch, , xlValues, xlWhole)
If Not rng1 Is Nothing Then
'Add Value to Sheet1
Sheets(1).Range("E4").Value = rng1.Offset(0, 1)
Else
Sheets(1).Range("E4").Value = 0
End If
strSearch = "Actual Hours"
Set rng1 = Range("A:A").Find(strSearch, , xlValues, xlWhole)
If Not rng1 Is Nothing Then
Sheets(1).Range("D4").Value = rng1.Offset(0, 1)
Else
Sheets(1).Range("D4").Value = 0
'Move on to next
End If
strSearch = "Name"
Set rng1 = Range("A:A").Find(strSearch, , xlValues, xlWhole)
If Not rng1 Is Nothing Then
Sheets(1).Range("J4").Value = rng1.Offset(0, 1)
Else
Sheets(1).Range("J4").Value = "NULL"
End If
'Scrape Description
Dim desc As String
HTML_Content.getElementsByTagName ("div")
desc = HTML_Content.getElementsByTagName("p")(0).innerText
Sheets(1).Range("K4").Value = desc
'Keep Sheet 1 Open
Sheets(1).Activate
'Delete ESTIMATE Sheet
Application.DisplayAlerts = False
Sheets(2).Delete
Application.DisplayAlerts = True
Error:
End Sub
The starting row of the hyperlink is L4, how could I make a loop that cycles through all links located in the L column and runs this script for each hyperlink that is in column L? How would I make a variable to so that Range will know what row is currently being processed?
Could I put my code into something like this:
For Each i In Sheet1.Range("L4:L200")
' code here
Next i
Any help is much appreciated, thank you.
change
Sub ImportData()
...
.Open "GET", Range("L4"), False 'Cell that contains hyperlink
...
into
Sub ImportData(urlToOpen as string)
...
.Open "GET", urlToOpen, False 'Cell that contains hyperlink
...
and add a calling procedure:
Sub CallRangeL_Urls
For Each i In Sheet1.Range("L4:L200")
' code here
call ImportData(i)
Next i
end sub
UPDATE 1
To get data from the procedure you might either send it back into the main procedure or you prepare a place prior to calling the procedure:
either:
Sub CallRangeL_Urls
For Each i In Sheet1.Range("L4:L200")
' code here
call ImportData(i, returnValue)
i.offset(0,1).value = returnValue
Next i
end sub
Sub ImportData(urlToOpen as string, returnValue as string)
...
'returnValue = Data you want to give back
returnValue = DataSource...(I didn't read your code again ;-)
...
or:
Sub CallRangeL_Urls
Dim targetRange as Range
For Each i In Sheet1.Range("L4:L200")
' code here
sheets.add after:=sheets(1)
'set a link on the sheet
Range("A1").value = i
Set targetRange = Range("A3")
call ImportData(i, targetRange)
Next i
end sub
Sub ImportData(urlToOpen as string, target as range)
...
'Save whatever data to the new sheet
target.offset(0,0).value = datavalue1 'Range("A3")
target.offset(1,0).value = datavalue1 'Range("A4")
target.offset(2,0).value = datavalue1 'Range("A5")
...
UPDATE 2
UPDATE 2: single data items (working example)
Option Explicit
Sub CallRangeL_Urls()
Dim iCell As Range
Dim Sheet1 As Worksheet
Dim returnValue As String
Set Sheet1 = ActiveSheet
For Each iCell In Sheet1.Range("L4:L4")
' code here
Debug.Print "url: "; iCell.Value
Call ImportData(iCell.Value, returnValue)
iCell.Offset(0, 1).Value = returnValue
Debug.Print returnValue
Next iCell
End Sub
Sub ImportData(urlToOpen As String, ByRef returnValue As String)
'...
'returnValue = Data you want to give back
returnValue = "This is the data we get back from yourUrl: " & urlToOpen & " - DATA/DATA/DATA" 'DataSource...(I didn't read your code again ;-)
End Sub
Immediate window:
url: www.google.de
This is the data we get back from yourUrl: www.google.de - DATA/DATA/DATA
UPDATE 2: data on result sheet(s) (working example)
Option Explicit
Sub CallRangeL_Urls()
Dim iCell As Range
Dim targetRange As Range
Dim Sheet1 As Worksheet
Set Sheet1 = ActiveSheet
For Each iCell In Sheet1.Range("L4:L4")
'create a new "RESULTS" sheets
Sheets.Add after:=Sheets(1)
Debug.Print "New sheet created: " & ActiveSheet.Name
'set a link on the sheet
Range("A1").Value = iCell.Value 'leave a copy of the url on the sheet as a reference
Set targetRange = Range("A3") 'here we want to get the results
Call ImportData(iCell.Value, targetRange)
Next iCell
End Sub
Sub ImportData(urlToOpen As String, target As Range)
Dim datavalue1, datavalue2, datavalue3
'...
datavalue1 = "data value 1"
datavalue2 = "data value 2"
datavalue3 = "data value 3"
'Save whatever data to the new sheet
target.Offset(0, 0).Value = datavalue1 'Range("A3")
target.Offset(1, 0).Value = datavalue2 'Range("A4")
target.Offset(2, 0).Value = datavalue3 'Range("A5")
Debug.Print "datavalues stored on sheet: " & target.Parent.Name
'...
End Sub
Immediate window:
New sheet created: Sheet2
datavalues stored on sheet: Sheet2
Hi I have the following Code:
Sub test()
Dim objData As DataObject ' Set a reference to MS Forms 2.0
Dim sHTML As String
Dim sSelAdd As String
Dim rng As Range
Cells(2, 7).Value = Cells(2, 7).Value
Set rng = ActiveSheet.Cells(2, 7)
Set objData = New DataObject
sHTML = rng.Text
objData.SetText sHTML
objData.PutInClipboard
ActiveSheet.PasteSpecial Format:="Unicode Text"
End Sub
However I was wondering if there is a way to use this method:
ActiveSheet.PasteSpecial Format:="Unicode Text"
In some sort of a way where I define the Paste range as well. It seems the text which is being pasted is copied in multiple cells overwriting other ones.
You could paste it to the currently selected cell, which can be very intuitive and useful for the end user:
Selection.PasteSpecial Format:="Unicode Text"
If you want to define the location in the code then you could do something like this:
Range("A1").PasteSpecial Format:="Unicode Text"
Edit: Today I learned that Range.PasteSpecial is different from Worksheet.PasteSpecial.
It looks like you can choose where you want to paste the data by selecting the cell before attempting to paste. This appears to do the trick for me:
Sub test()
Dim objData As DataObject ' Set a reference to MS Forms 2.0
Dim sHTML As String
Dim sSelAdd As String
Dim rng As Range
Cells(2, 7).Value = Cells(2, 7).Value
Set rng = ActiveSheet.Cells(2, 7)
Set objData = New DataObject
sHTML = rng.Text
objData.SetText sHTML
objData.PutInClipboard
rng.Select '<----Add this line.
ActiveSheet.PasteSpecial Format:="Unicode Text"
End Sub
I found this to work:
Private Sub Worksheet_Activate()
Dim objData As DataObject ' Set a reference to MS Forms 2.0
Dim sHTML As String
Dim sSelAdd As String
Dim rng As Range
Cells(1, 7).Value = Cells(1, 7).Value
Set rng = ActiveSheet.Cells(1, 7)
Set objData = New DataObject
sHTML = rng.Text
objData.SetText (sHTML)
objData.PutInClipboard
rng.Select
Worksheets("GridData").Range("G1").Select
ActiveSheet.PasteSpecial Format:= _
"Unicode Text"
End Sub
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