I am following this websites method https://www.automateexcel.com/vba/word/bookmarks of using the existing bookmark range to change text and reinsert. However I get a type mismatch error when I try to set the range for my existing bookmarks. When I hover over StartDate in VBE it says 'Nothing'. I have tried it with wdApp.ActiveDocument.Bookmarks rather than GIR.Bookmarks as well and get the same issue. Any ideas? Thanks
Sub GIToWord()
'
' Select GI Summary data in excel and copy to GIR
'
'
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Dim wb As Workbook
Dim ws As Worksheet
Dim wdApp As Word.Application
Dim GIR As Word.Document
Dim GIRName As String
Dim Start As Date
Dim Finish As Date
Dim iNum As Integer
Dim iMax As Integer
Dim First As Date
Dim Last As Date
Dim StartDate As Range
Dim EndDate As Range
Dim NumLocations As Range
Dim MaxDepth As Range
Dim FirstRound As Range
Dim LastRound As Range
Set wdApp = New Word.Application '<<< Create a Word application object
wdApp.Visible = True '<<<< Open word so you can see any errors
GIRName = Application.GetOpenFilename(Title:="Please choose GIR to open", _
FileFilter:="Word Files *.docm* (*.docm*),")
Set GIR = wdApp.Documents.Open(GIRName) '<< call Documents.Open on the word app
'Assign data to variables
Set wb = ThisWorkbook
Set ws = ActiveSheet
Start = ws.Cells(2, 5)
Finish = ws.Cells(2, 6)
iNum = ws.Cells(2, 1)
iMax = ws.Cells(2, 4)
First = ws.Cells(11, 35)
Last = ws.Cells(11, 36)
'Paste data into word at associated bookmarks and recreate
Set StartDate = GIR.Bookmarks("StartDate").Range
StartDate.Text = Start
GIR.Bookmarks.Add "StartDate", StartDate
Set EndDate = GIR.Bookmarks("EndDate").Range
EndDate.Text = Finish
GIR.Bookmarks.Add "EndDate", EndDate
Set NumLocations = GIR.Bookmarks("NumLocations").Range
NumLocations.Text = iNum
GIR.Bookmarks.Add "NumLocations", NumLocations
Set MaxDepth = GIR.Bookmarks("MaxDepth").Range
MaxDepth.Text = iMax
GIR.Bookmarks.Add "MaxDepth", MaxDepth
Set FirstRound = GIR.Bookmarks("FirstRound").Range
FirstRound.Text = First
GIR.Bookmarks.Add "FirstRound", FirstRound
Set LastRound = GIR.Bookmarks("LastRound").Range
LastRound.Text = Last
GIR.Bookmarks.Add "LastRound", LastRound
GIR.Save
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Related
I want to export e-mail data from a specific folder by a range of dates.
The macro exports the received date and the body of the email.
The objective is to search for certain data that comes from the extracted body and show them in other rows.
Due to the 32767 character limit that Excel has in a cell, the bodies of some emails are not being fully exported.
Is there a way to export the body in two rows instead of one to avoid the Excel limitation?
Other suggestions to accomplish this process are appreciated.
Sub ImportEmails()
Dim OutlookApp As Outlook.Application
Dim OutlookNamespace As Outlook.Namespace
Dim IFolder As Outlook.MAPIFolder
Dim OutlookMail As Variant
Dim i As Integer
Dim wb As Workbook
Dim ws As Worksheet
Dim rng As Range
Set OutlookApp = New Outlook.Application
'Outlook connection
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
Set wb = ThisWorkbook
'Select the folder to export emails, depending on the user´s folder name you must change it
Set IFolder = OutlookNamespace.GetDefaultFolder(olFolderInbox).Folders("Test")
Set ws = wb.Sheets("Imported")
i = 0
Application.ScreenUpdating = False
ws.Cells.Clear
'Create headers
ws.Range("A1").Value = "Date Time"
ws.Range("B1").Value = "Body"
'Condition to select the today date in case of blank and export the emails
If IsEmpty(Range("end_date").Value) = True Then
Range("end_date").Value = "=today()"
End If
'Exporting proccedure
For Each OutlookMail In IFolder.Items
'Date validation
If DateValue(OutlookMail.ReceivedTime) >= DateValue(Range("start_date")) And DateValue(OutlookMail.ReceivedTime) <= DateValue(Range("end_date")) Then
'Fill the worksheet cells with the emails
ws.Range("A2").Offset(i, 0).Value = OutlookMail.ReceivedTime
ws.Range("B2").Offset(i, 0).Value = OutlookMail.Body
i = i + 1
End If
Next OutlookMail
Application.ScreenUpdating = True
Set IFolder = Nothing
Set OutlookNamespace = Nothing
Set OutlookApp = Nothing
LRimpr = LastRow(ws)
Set rng = ws.Range("A2:B" & LRimpr)
'Sort the columns by newest to oldest using the worksheet last row
With rng
.Sort Key1:=.Cells(1), Order1:=xlDescending, _
Orientation:=xlTopToBottom, Header:=xlNo
End With
MsgBox "Emails are successfully imported", vbInformation, "Import complete"
ws.Activate
End Sub
If you would be happy exporting the email body in multiple cells in a single row then replace your line
ws.Range("B2").Offset(i, 0).Value = OutlookMail.Body
with
Const CHUNK_SIZE As Long = 32000
Dim segment As Long
segment = 0
Do While True
ws.Range("B2").Offset(i, segment).Value = Mid$(OutlookMail.Body, segment * CHUNK_SIZE + 1, CHUNK_SIZE)
segment = segment + 1
If segment * CHUNK_SIZE > Len(OutlookMail.Body) Then Exit Do
Loop
Adjust the value for CHUNK_SIZE to your requirements ... it controls the number of characters that will be put into each cell, with the last cell having the 'remaining' characters (or all the characters if the body has less characters than CHUNK_SIZE)
To split the body into cells in a column.
Option Explicit
Sub ImportEmails_SplitBody_MultipleRows()
' Reference Microsoft Outlook nn.n Object Library
Dim OutlookApp As Outlook.Application
Dim iFolder As Outlook.Folder
Dim iFolderItems As Outlook.Items
Dim j As Long
Dim OutlookItem As Object
Dim lenBody As Long
Dim maxLen As Long
Dim i As Long
Dim wb As Workbook
Dim ws As Worksheet
Dim rng As Range
Set OutlookApp = New Outlook.Application
' Select folder
Set iFolder = Session.GetDefaultFolder(olFolderInbox).Folders("Test")
' Sort items
Set iFolderItems = iFolder.Items
iFolderItems.Sort "[ReceivedTime]", True
Set wb = ThisWorkbook
Set ws = wb.Sheets("Imported")
i = 0
' Application is Excel. No impact on Outlook
'Application.ScreenUpdating = False
ws.Cells.Clear
'Create headers
ws.Range("A1").Value = "Date Time"
ws.Range("B1").Value = "Body"
'Condition to select today's date in case of blank
If IsEmpty(Range("end_date").Value) = True Then
Range("end_date").Value = "=today()"
End If
'Debug.Print Range("start_date")
'Debug.Print Range("end_date")
'Exporting procedure
maxLen = 32767
'Debug.Print " maxLen: " & maxLen
For j = 1 To iFolderItems.Count
'Date validation
If iFolderItems(j).Class = olMail Then
Set OutlookItem = iFolderItems(j)
'Debug.Print OutlookItem.Subject
If DateValue(OutlookItem.ReceivedTime) >= DateValue(Range("start_date")) And _
DateValue(OutlookItem.ReceivedTime) <= DateValue(Range("end_date")) Then
lenBody = Len(OutlookItem.Body)
Dim txt As String
txt = OutlookItem.Body
Dim lenTxt As Long
lenTxt = Len(txt)
Do Until lenTxt = 0
'Fill the worksheet cells with the emails
'Debug.Print " Len(txt): " & Len(txt)
If lenTxt > maxLen Then
ws.Range("A2").Offset(i, 0).Value = OutlookItem.ReceivedTime
ws.Range("B2").Offset(i, 0).Value = Left(txt, maxLen)
txt = Right(txt, Len(txt) - maxLen)
Else
ws.Range("A2").Offset(i, 0).Value = OutlookItem.ReceivedTime
ws.Range("B2").Offset(i, 0).Value = txt
txt = ""
End If
i = i + 1
lenTxt = Len(txt)
Loop
Set OutlookItem = Nothing
End If
End If
Next
Application.ScreenUpdating = True
Set iFolder = Nothing
Set iFolderItems = Nothing
Set OutlookApp = Nothing
MsgBox "Emails are successfully imported", vbInformation, "Import complete"
ws.Activate
End Sub
I'd like to open a bunch of word files, from a list of file names in my excel workbook, activate the opened word files, perform a text replacement, and save the changes.
I can't make the liaison between Excel VBA and Word files.
Dim wdApp As Object, wddoc As Object
'Declare a string variable for Word document
Dim strDocName As String
On Error Resume Next
Set wdApp = CreateObject("Word.Application")
wdApp.Visible = True
strDocName = xDPathStr \ "FILENAME.docx" '(xDPathStr is the path I have defined earlier with all the word files)'
'Open Word File
wdApp.Activate
Set wddoc = wdApp.Documents(strDocName)
If wddoc Is Nothing Then Set wddoc = wdApp.Documents.Open(strDocName)
wddoc.Activate
wrdApp.Visible = True
Modify Word Files From a List in Excel
It is assumed that the file names are in column A. It will open each file and replace all occurrences of one string with another.
The focus here is on how to reference (open) Word, open files, modify them (not so much), close them with saving changes, and finally close Word only if it was initially closed.
Option Explicit
Sub VisitWord()
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Late Binding (not recommended at this stage)
' When you get familiar with how it works, switch to Late Binding:
' Dim wdApp As Object
' Dim WordWasClosed As Boolean
' On Error Resume Next ' see if Word is open
' Set wdApp = GetObject(, "Word.Application") ' attempt to create a reference to it
' On Error GoTo 0
' If wdApp Is Nothing Then ' Word is not open
' WordWasClosed = True
' Set wdApp = CreateObject("Word.Application") ' open and create a reference to it
' End If
' wdApp.Visible = True ' default is false; outcomment when done testing
' Dim wdDoc As Object
' ' etc.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Early Binding
' For this to work, in Excel, you need to create a reference to
' Tools > References > Microsoft Word 16.0 Object Library
' Use this to have the Word intellisense work for you.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Const WordFolderPath As String = "C:\Test\"
Const FINDSTRING As String = "Old String"
Const REPLACESTRING As String = "New String"
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Worksheets("Sheet1")
Dim rg As Range
Set rg = ws.Range("A2", ws.Cells(ws.Rows.Count, "A").End(xlUp))
Dim wdApp As Word.Application
Dim WordWasClosed As Boolean
On Error Resume Next ' see if Word is open
Set wdApp = Word.Application ' attempt to create a reference to it
On Error GoTo 0
If wdApp Is Nothing Then ' Word is not open
WordWasClosed = True
Set wdApp = New Word.Application ' open and create a reference to it
End If
wdApp.Visible = True ' default is false; outcomment when done testing
Dim cell As Range
Dim wdDoc As Word.Document
Dim WordFileName As String
Dim WordFilePath As String
For Each cell In rg.Cells
WordFileName = CStr(cell.Value)
If Len(WordFileName) > 0 Then
WordFilePath = WordFolderPath & WordFileName
If Len(Dir(WordFilePath)) > 0 Then ' file exists
Set wdDoc = wdApp.Documents.Open(WordFilePath)
' Here you do the damage...
wdDoc.Content.Find.Execute _
FindText:=FINDSTRING, _
ReplaceWith:=REPLACESTRING, _
Format:=True, _
Replace:=wdReplaceAll
wdDoc.Close SaveChanges:=True
End If
End If
Next cell
If WordWasClosed Then wdApp.Quit
End Sub
So this is the code i've come up with so far:
Dim wdApp As Object, wddoc As Object
'Declare a string variable for Word document
Dim strDocName As String
On Error Resume Next
Set wdApp = CreateObject("Word.Application")
wdApp.Visible = True
strDocName = xDPathStr \ "FILENAME.docx" '(xDPathStr is the path I have defined earlier with all the word files)'
'Open Word File
wdApp.Activate
Set wddoc = wdApp.Documents(strDocName)
If wddoc Is Nothing Then Set wddoc = wdApp.Documents.Open(strDocName)
wddoc.Activate
wrdApp.Visible = True
Here is some sample code that I created recently to loop through cells in Excel, which are paths to Word files. Each Word file is opened, scanned for a table (in Word), and copy/paste to Excel. See if you can start with this. Post back if you have additional questions.
Sub LoopThroughAllWordFiles()
Dim wdApp As New Word.Application, wdDoc As Word.Document
Dim oTbl As Word.Table
Dim strFolder As String, strFile As String
Dim WkSht As Worksheet
Dim cnt As Long
Dim tableCount As Long
Dim lrow As Long
Dim lastrow As Long
Dim file As String
Dim rng As Range, cell As Range
Dim objDoc As Object
Dim objWord As Object
Dim StartTime As Double
Dim SecondsElapsed As Double
StartTime = Timer
Set rng = Worksheets("Files").Range("A1:A200")
Worksheets("Word_Tables").Select
filecounter = 1
cnt = 1
Set objWord = CreateObject("Word.Application")
obj.Word.Visible = False
For Each cell In rng.SpecialCells(xlCellTypeVisible)
MyStr = Right(cell, 5)
If MyStr = ".docx" Then
mylength = Len(cell)
pos = InStrRev(cell, "\")
strFolder = Left(cell, pos)
strFile = Right(cell, mylength - pos)
Worksheets("Word_Files").Select
Set objWord = wdApp.Documents.Open(Filename:=strFolder & strFile, AddToRecentFiles:=False, ReadOnly:=True, Visible:=False)
Set sht = ThisWorkbook.Worksheets("Word_Files")
lastrow = Worksheets("Word_Files").UsedRange.Rows.Count + 1
totTbl = objDoc.Tables.Count
Debug.Print totTbl
For Each oTbl In objDoc.Tables
strCellText = oTbl.cell(1, 1).Range.Text
strCellText = LCase(strCellText)
Debug.Print strCellText
If strCellText Like "*data input*" Then
Worksheets("Word_Files").Range("A" & lastrow) = strFolder & strFile
On Error Resume Next
If cnt = 1 Then
lastrow = lastrow
Else
lastrow = ActiveSheet.UsedRange.Rows.Count
End If
oTbl.Range.Copy
Range("B" & lastrow).Select
sht.Paste
cnt = cnt + 1
End If
Next oTbl
End If
filecounter = filecounter + 1
Debug.Print filecounter
objWord.Close
Next cell
objDoc.Quit
Set objDoc = Nothing
objWord.Quit
Set objWord = Nothing
SecondsElapsed = Round(Timer - StartTime, 2)
SecondsFinal = SecondsElapsed / 60
MsgBox ("Code ran in " & SecondsFinal & "minutes.")
End Sub
I have a long list of word documents which all have three pages. now i want every fist page in document 1, every 2nd page in document 2 and every 3rd page in document 3. I have tags on every page in my word document but every page has the same tag. I need to search for the tags, select the tags and everything in between and move them to the new document. Then, search again to find the 2nd tag (which is the same text as the first one) and do the same thing.
I have an excel sheet with the filenames/locations of all the documents with the tags, so i'm running all this from excel vba.
I've made an attempt to find/select the code, but it selects the first and the last tag, not the first one. Could you help me out?
This is my current code for opening the word docs one by one and finding tags:
Sub SelectRangeBetween()
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Sheet1") 'Change to the correct sheetname
Dim wrdApp As Word.Application
' Set wrdApp = CreateObject("Word.Application")
Dim WrdDoc As Word.Document
Set wrdApp = New Word.Application '
wrdApp.Visible = True 'set to false for higher speed
Const StarttagColumn = "C" 'Edit this for the column of the starttag.
Const EndtagColumn = "D" 'Edit this for the column of the endtag.
Const FilelocationColumn = "E" 'Edit this for the column of the Filelocation.
Const startRow As Long = 5 'This is the first row of tags and filenames
'Const endRow As Long = 140 'uncomment if you want a fixed amount of rows (for ranges with empty cells)
Dim endRow As Long 'comment out if const-endrow is used
endRow = ws.Range("B" & Rows.Count).End(xlUp).Row 'comment out if const-endrow is used
Dim i As Long
For i = startRow To endRow
Dim wrdPath As String
wrdPath = ws.Cells(i, FilelocationColumn).Value2 '
If wrdPath <> vbNullString Then '
If Dir(wrdPath) <> vbNullString Then '
Dim startTag As String '
Dim endTag As String '
startTag = ws.Cells(i, StarttagColumn).Value2 '
endTag = ws.Cells(i, EndtagColumn).Value2 '
Set WrdDoc = wrdApp.Documents.Open(wrdPath) '
With wrdApp
With .ActiveDocument.Content.Duplicate
.Find.Execute Findtext:=startTag & "*" & endTag, MatchWildcards:=False, Forward:=False
.MoveStart wdCharacter, Len(startTag)
.MoveEnd wdCharacter, -Len(endTag) - 1
.Select ' Or whatever you want to do
End With
End With
With WrdDoc
.Close
End With
End If
End If
Next i
End Sub
Try this:
Private Sub Combine()
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Sheet1") 'Change to the correct sheetname
Const StarttagColumn = "C" 'Edit this for the column of the starttag.
Const EndtagColumn = "D" 'Edit this for the column of the endtag.
Const FilelocationColumn = "E" 'Edit this for the column of the Filelocation.
Const startRow As Long = 5 'This is the first row of tags and filenames
'Const endRow As Long = 140 'uncomment if you want a fixed amount of rows (for ranges with empty cells)
Dim endRow As Long 'comment out if const-endrow is used
endRow = ws.Range("B" & Rows.Count).End(xlUp).Row
Dim wrdApp As Word.Application
Set wrdApp = New Word.Application
wrdApp.Visible = True
Dim page1Doc As Word.Document
Set page1Doc = wrdApp.Documents.Add
Dim page2Doc As Word.Document
Set page2Doc = wrdApp.Documents.Add
Dim page3Doc As Word.Document
Set page3Doc = wrdApp.Documents.Add
Dim i As Long
For i = startRow To endRow
Dim wrdPath As String
wrdPath = ws.Cells(i, FilelocationColumn).Value2 '
If wrdPath <> vbNullString Then '
If Dir(wrdPath) <> vbNullString Then
Dim endTag As String
endTag = ws.Cells(i, EndtagColumn).Value2
Dim extractDoc As Word.Document
Set extractDoc = wrdApp.Documents.Open(wrdPath)
'Find first endtag
Dim page1Rng As Word.Range
Set page1Rng = extractDoc.Range.Duplicate
With page1Rng.Find
.Text = endTag
.Execute
End With
If page1Rng.Find.Found Then
page1Rng.SetRange 0, page1Rng.End + 1
page1Rng.Cut
page1Doc.Paragraphs.Last.Range.Paste
Set page1Rng = Nothing
'If success, find second endtag
Dim page2Rng As Word.Range
Set page2Rng = extractDoc.Range.Duplicate
With page2Rng.Find
.Text = endTag
.Execute
End With
If page2Rng.Find.Found Then
page2Rng.SetRange 0, page2Rng.End + 1
page2Rng.Cut
page2Doc.Paragraphs.Last.Range.Paste
Set page2Rng = Nothing
'If success, yolo and cut the rest since it should left with 3rd page
extractDoc.Range.Cut
page3Doc.Paragraphs.Last.Range.Paste
Dim breakRng As Word.Range
Set breakRng = page3Doc.Paragraphs.Last.Range.DuplicateWith page3Doc.Paragraphs.Last.Range.Duplicate
.Collapse
.InsertBreak
End With
End If
End If
extractDoc.Close 0
End If
End If
Next i
Set extractDoc = Nothing
Set page1Doc = Nothing
Set page2Doc = Nothing
Set page3Doc = Nothing
Set ws = Nothing
MsgBox "Done!"
End Sub
I am using Office 365 on a Windows 10 64-bit pc.
I have a Word document with a table into which I want to copy elements from an Excel document. The elements are a) text from its cell, b) a hyperlink from its cell and c) images from a list of images.
The first two tasks are performed successfully by the following sub:
Sub ImportFromExcel()
Dim RowNo As Long, RowTarget As Long
Dim RowFirst As Long, RowLast As Long
Dim strContent As String, strLink As String, strDisplay As String
Dim xlAppl As New Excel.Application
Dim xlBook As New Excel.Workbook
Dim xlSheet As New Excel.Worksheet
Dim ExcelFileName As String
Dim tbl As Word.Table
On Error GoTo Finish
ExcelFileName = "C:\MyPath\MyExcelDoc.xlsm"
Set xlAppl = CreateObject("Excel.Application")
xlAppl.Application.Visible = False
xlAppl.Workbooks.Open ExcelFileName
Set xlBook = xlAppl.ActiveWorkbook
Set xlSheet = xlBook.Worksheets("Titan")
Set tbl = ActiveDocument.Tables(1)
RowFirst = 6: RowLast = 19
For RowNo = RowFirst To RowLast
RowTarget = RowNo - RowFirst + 1
strContent = xlSheet.Cells(RowNo, 5).Value
tbl.Cell(RowTarget, 1).Range.Text = strContent
strDisplay = xlSheet.Cells(RowNo, 3).Value
tbl.Cell(RowTarget, 3).Range.Text = strContent
strLink = xlSheet.Cells(RowNo, 3).Hyperlinks(1).Address
InsertHyperlinkInTable tbl, RowTarget, 3, strLink, strDisplay
' CopyImageFromExcelToWord xlSheet, RowTarget, tbl
Next RowNo
Finish:
xlAppl.ActiveWorkbook.Close False ' Word will not freeze at this point
xlAppl.Quit
Set xlSheet = Nothing
Set xlBook = Nothing
Set xlAppl = Nothing
End Sub
I copy the hyperlink by reading its address and caption and then recreating it in Word.
Also from Word I can select a give image by way of its index using the first two active lines of the following sub:
Sub CopyImageFromExcelToWord(xlSheet As Excel.Worksheet, imgNo As Long, tbl As Word.Table)
Dim strId As String
' Syntax at https://learn.microsoft.com/en-us/office/vba/api/excel.worksheet.select
strId = "Picture " & CStr(2 * imgNo)
xlSheet.Shapes.Range(Array(strId)).Select
' Missing link !
With tbl.Cell(1, 4)
.Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
.VerticalAlignment = wdCellAlignVerticalCenter
.Select
End With
Selection.PasteAndFormat (wdFormatOriginalFormatting)
End Sub
An image residing in the clipboard can be inserted into Word using the last six lines.
But I have not found out how to copy the image I selected in the Excel document to the clipboard with a Word macro.
Can this be done somehow?
Can the copying of the hyperlink be performed in a smarter way?
Try
Sub CopyImageFromExcelToWord(xlSheet As Excel.Worksheet, imgNo As Long, tbl As Word.Table)
Dim strId As String
' Syntax at https://learn.microsoft.com/en-us/office/vba/api/excel.worksheet.select
strId = "Picture " & CStr(2 * imgNo)
xlSheet.Shapes.Range(Array(strId)).Item(1).Copy
With tbl.Cell(1, 4)
.Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
.VerticalAlignment = wdCellAlignVerticalCenter
.Range.PasteAndFormat wdFormatOriginalFormatting
End With
End Sub
I'm new to VBA and I'm having difficulty trying to insert comments from data that I have in Excel onto a Word document. I am trying to write the VBA in Word and want it to extract data from a separate spreadsheet
Sub ConvertCelltoWordComment()
Dim Rng As Range
Dim wApp As Object
Dim strValue As String
Dim xlapp As Object
Dim xlsheet As Object
Dim xlbook As Object
'Opens Excel'
Set xlapp = GetObject("C:\Users\eugenechang\Desktop\...xlsx")
If Err Then
Set xlapp = CreateObject("Excel.Application")
End If
On Error GoTo 0
Dim i As Integer
For i = 1 To 5
With xlsheet
strValue = ActiveSheet.Cells(i, 1).Offset(1, 0)
End With
'Insert comment into document'
ActiveDocument.Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext, Name:="15"
ActiveDocument.Selection.GoTo What:=wdGoToLine, Which:=wdGoToRelative, Count:=5
ActiveDocument.Comments.Add Range:=Selection.Range, Text:=strValue
Next i
End Sub
I'm trying to get it to work, but it is giving me an error "Object not defined". I've tried setting up an object within the strValue line below "With xlsheet", but am hitting a wall. Any help??
You have not assigned anything to xlsheet - so this (by default) equates to Nothing.
Try setting xlSheet to something meaningful. The following is only an example:
For i = 1 To 5
Set xlsheet = xlbook.Worksheets(i) ' <--- example here
With xlsheet
strValue = .Cells(i, 1).Offset(1, 0) '<-- don't use ActiveSheet
End With
'Insert comment into document'
ActiveDocument.Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext, Name:="15"
ActiveDocument.Selection.GoTo What:=wdGoToLine, Which:=wdGoToRelative, Count:=5
ActiveDocument.Comments.Add Range:=Selection.Range, Text:=strValue
Next I
An important note here is that you also have not set xlbook - you must also assign something meaningful to xlbook.
Add a couple DocVariables to your Word file and run the script below, from Excel.
Sub PushToWord()
Dim objWord As New Word.Application
Dim doc As Word.Document
Dim bkmk As Word.Bookmark
sWdFileName = Application.GetOpenFilename(, , , , False)
Set doc = objWord.Documents.Open(sWdFileName)
'On Error Resume Next
objWord.ActiveDocument.variables("FirstName").Value = Range("FirstName").Value
objWord.ActiveDocument.variables("LastName").Value = Range("LastName").Value
' etc., etc., etc.
objWord.ActiveDocument.Fields.Update
'On Error Resume Next
objWord.Visible = True
End Sub
This ended up writing comments from an Excel file. Obviously the names have been changed for privacy reasons. Please let me know if I can simplify this better.
Sub ConvertExceltoWordComment()
Dim wApp As Word.Application
Dim xlApp As Excel.Application
Dim PgNum As Integer
Dim LineNum As Integer
Dim objSelection As Word.Document
Dim strpgSearch As Long
Dim strlinSearch As Long
Dim myRange As Range
Dim XlLog As Excel.Worksheet
Dim RowCount As Long
'Opens Copied Word document'
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
If Err Then
Set xlApp = CreateObject("Excel.Application")
End If
On Error GoTo 0
Dim SaveDoc As Excel.Workbook
Set SaveDoc = xlApp.Workbooks.Open("FilePath.xlsm") 'Type filepath of document here'
Set XlLog = SaveDoc.Sheets("Worksheet_Name") 'Type Sheetname here'
RowCount = XlLog.Range("A1048576").End(xlUp).Row
If RowCount > 0 Then
Dim iTotalRows As Long
iTotalRows = XlLog.Rows.Count 'Get total rows in the table'
Dim txt As Variant
Dim iRows As Long
End If
Dim i As Integer
'Insert comment into Word document'
Set wApp = CreateObject("Word.Application")
wApp.Visible = True
If Err Then
Set wApp = CreateObject("Word.Application")
End If
Set objSelection = ActiveDocument
For iRows = 3 To iTotalRows
txt = XlLog.Cells(iRows, 8).Text 'Grabs appropriate comment text'
objSelection.Activate
objSelection.SelectAllEditableRanges
strpgSearch = XlLog.Cells(iRows, 2) 'Grabs appropriate Page number'
strlinSearch = XlLog.Cells(iRows, 3) 'Grabs appropriate Line number'
objSelection.ActiveWindow.Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext,
Name:=strpgSearch
objSelection.ActiveWindow.Selection.GoTo What:=wdGoToLine, Which:=wdGoToRelative,
Count:=strlinSearch
Set myRange = ActiveWindow.Selection.Range
ActiveDocument.Comments.Add Range:=myRange, Text:=txt
Next iRows
Set xlApp = Nothing
Set SaveDoc = Nothing
Set XlLog = Nothing
Set objSelection = Nothing
Set myRange = Nothing
Set wApp = Nothing
SaveDoc.Close
End Sub