I'm tying to write a Macro to automatically find and replace words in a MS-word doc (800+ words) using an Excel database. Yet when I tell it to open the excel sheet I get Run-time error '1004': Excel cannot access 'Documents' (the folder where my spreadsheet is). Here's the macro I'm using (which I found here):
Function findAndReplace()
Dim xlApp As Object
Dim xlWB As Object
Dim xlWS As Object
Dim i As Integer, j As Integer
Dim lastRow As Integer
'Set Objects
Set xlApp = CreateObject("Excel.Application")
Set xlWB = xlApp.Workbooks.Open("C:\Users\...\Documents")
'Replace String with path to Excel File
Set xlWS = xlWB.Worksheets("Word list for Macro")
'Replace String with your Worksheet Name
'get last row of excel file
lastRow = xlWS.UsedRange.SpecialCells(xlCellTypeLastCell).Row
'loop through all words in Word Document
For i = 1 To ThisDocument.Words.Count - 1 Step 1
'Loop through cells in Excel File
For j = 1 To lastRow Step 1
'Replace Word value in Column B of Excel File
ThisDocument.Words(i) = Replace(ThisDocument.Words(i), xlWS.Cells(j, 1).Value, xlWS.Cells(j, 2).Value)
Next j
Next i
'Close Excel and Cleanup
Set xlWS = Nothing
xlWB.Close True
Set xlWB = NothingxlApp.Quit
Set xlApp = Nothing
End Function
Run-time error '1004': Excel cannot access 'Documents' (the folder where my spreadsheet is)
It seems the following line of code gives the error message:
Set xlWB = xlApp.Workbooks.Open("C:\Users\...\Documents")
Make sure the specified folder exists on the disk. The user name can be different on each machine, so you may get such errors if you move your code to another machine.
So, I'd suggest copying the path and opening the folder manually.
Related
I have a set of word documents that I want to auto-fill for different clients and I am trying to write a VBA application to accomplish that. I have information about the client, such as today's date and their name, stored in an Excel sheet, and I want to copy that information on multiple Word documents with labels on them. The goal is for every new client, the user would only need to update the client information on the Excel sheet to auto-fill the Word documents.
The below code is what I have right now. objDocument represents the Word document that I am trying to fill in and exWb is the Excel sheet in which I am trying to copy client information from. The Excel sheet has cells named TodayDate and ClientName which stores the respective client information. The Word document has ActiveX control labels named TodayDate, ClientName, and ClientName1 which will be filled in with the corresponding information from the Excel Sheet. ClientName and ClientName1 both contain the information from the "ClientName" cell, but because I cannot have 2 labels of the same name in Word, they are named as such.
Dim objDocument As Document
Set objDocument = Documents.Open(strPath)
objDocument.Activate
Dim objExcel As New Excel.Application
Dim exWb As Excel.Workbook
Set exWb = objExcel.Workbooks.Open(selectMasterPath)
On Error Resume Next
objDocument.TodayDate.Caption = exWb.Sheets("Sheet1").Range("TodayDate").Value
On Error Resume Next
objDocument.ClientName.Caption = exWb.Sheets("Sheet1").Range("ClientName").Value
On Error Resume Next
objDocument.ClientName1.Caption = exWb.Sheets("Sheet1").Range("ClientName").Value
On Error Resume Next
To make the code more readable, I would like to format it into a for loop, but I am not sure how to declare a variable that can refer to the names of Word document labels in a for loop. I was thinking of using arrays to store the names of Word labels and Excel cells and loop through the list. I suppose it would look something like this:
Dim objDocument As Document
Set objDocument = Documents.Open(strPath)
objDocument.Activate
Dim objExcel As New Excel.Application
Dim exWb As Excel.Workbook
Set exWb = objExcel.Workbooks.Open(selectMasterPath)
WordLabelList = [TodayDate, ClientName, ClientName1]
ExcelNames = ["TodayDate", "ClientName", "ClientName"]
Dim i as Integer
for i in range(1, length(WordLabelList))
On Error Resume Next
objDocument.WordLabelList[i].Caption = exWb.Sheets("Sheet1").Range(ExcelNames[i]).Value
Next
Or to make it even better, use a dictionary with ExcelNames as the key and WordLabelList as the values so that I do not have to repeat values in the ExcelNames array:
Dim objDocument As Document
Set objDocument = Documents.Open(strPath)
objDocument.Activate
Dim objExcel As New Excel.Application
Dim exWb As Excel.Workbook
Set exWb = objExcel.Workbooks.Open(selectMasterPath)
ClientInfo = {"TodayDate":[TodayDate], "ClientName": [ClientName, ClientName1]}
for info in ClientInfo
for label in ClientInfo[info].value
On Error Resume Next
objDocument.label.Caption = exWb.Sheets("Sheet1").Range(info).Value
Next
Please let me know how I can achieve any of the above with proper VBA syntax or if you have a more efficient suggestion that is better than re-writing multiple lines in original code.
The only thing you're missing seem to be a way to address an ActiveX control by its name? Once you have that your code gets much simpler.
For example:
Sub Tester()
Dim doc As Object, lbl As Object, nm
Set doc = ThisDocument
For Each nm In Array("TodayDate", "ClientName")
Set lbl = DocActiveX(doc, nm) 'get a reference to an embedded ActiveX control
If Not lbl Is Nothing Then
lbl.Caption = "this is - " & nm
Else
Debug.Print "Control '" & nm & "' not found"
End If
Next nm
End Sub
'return a reference to a named ActiveX control in document `doc`
' (or Nothing if not found)
Function DocActiveX(doc As Document, xName) As Object
Dim obj As Object
On Error Resume Next
Set obj = CallByName(doc, xName, VbGet)
On Error GoTo 0
Set DocActiveX = obj
End Function
I am new to VBA and macros.
I got the repeated task of copy data from Excel and paste it in a particular location in the word document.
For example, my excel sheet has the data like this:
Col1
Col2
ID_1
I'm_One
ID_2
I'm_Two
ID_3
I'm_Three
Now i'm looking for a Word macro
Get text in Word table with cell position 3
Find the same text in Excel Col1
Get the value of Col2 from Excel
Paste the value of Col2 in word table with cell position 10
Repeat the same process for another table in Word document
[Update]
I have tried with multiple code snippets by google search but unable to construct the working macro.
Sub pull_from_Excel2()
'ref: https://www.macworld.com/article/211753/excelwordvisualbasic.html
Dim Month As String
ID_Range = "A2:A6" 'Select this as range like "A2:A16"
Offset_to_fetch = 1 'Select this to fetch comments etc. value starts with
Set xlSheet = GetObject("D:\Excel.xlsx")
'Snippets:
'Debug.Print VarType(xlSheet.Worksheets("Sheet1").Range("A3:A5").Value)
'8204
Dim Cell As Range, rng As Range
Debug.Print VarType(xlSheet.Worksheets("Sheet1").Range(ID_Range).Value2)
Set rng = xlSheet.Worksheets(1).Range(ID_Range)
For Each Cell In rng
Debug.Print Cell.Text
Next Cell
End Sub
I used this url to construct my skeleton code: https://www.macworld.com/article/211753/excelwordvisualbasic.html
When i try to get the values from the range of cells in excel, i got the following error for the code.
Set rng = xlSheet.Worksheets(1).Range(ID_Range).Value2
The above line gives "Object required" error when running.
Set rng = xlSheet.Worksheets(1).Range(ID_Range)
The above line gives "Type Mismatch" error when running.
Notes: For this error, I tried to use for each loop as this is array but the error is showing before executing the for loop.
Kindly assist.
I recommend to use Option Explicit and declare all your varibales properly. This way it is less likely that you end up with unseen errors.
To activate it for all new codes that you add in the future, you can activate it directly in Excel and Word. This is a good practice and will protect you from doing it wrong by notifying you of not declared variables:
In the VBA editor go to Tools › Options › Require Variable Declaration.
This will add Option Explicit to new modules only. In existing modules Option Explicit needs to be added manually as first line.
Further I highly recommend to name your variables according what they contain because otherwise it gets very confusing. You named your variable xlSheet but you load a workbook into it and not a worksheet.
The next issue is that your code is in Word and if you declare rng As Range then this is of type Word.Range and not Excel.Range and those are diffetent types so that is why you get a "Type Mismatch" error.
To solve this you either go in Word VBA to Extras › Refereces … and set a reference to the Excel library so you can declare your variable Dim xlRng As Excel.Range or if you don't set a reference you declare it as Object or Variant like in below example:
' This code is in Word!
Option Explicit
Public Sub pull_from_Excel2()
'declare constants
Const ID_Range As Sting = "A2:A6" 'Select this as range like "A2:A16"
Const Offset_to_fetch As Long = 1 'Select this to fetch comments etc. value starts with
Dim xlWorkbook As Object
Set xlWorkbook = GetObject("D:\Excel.xlsx") 'This expects the Excel to be already open! If not open you need to use CreateObject("Excel.Application")
Dim xlRng As Object
Set xlRng = xlWorkbook.Worksheets(1).Range(ID_Range)
Dim xlCell As Object
For Each xlCell In xlRng
Debug.Print xlCell.Text
Next xlCell
End Sub
Note if your workbook Set xlWorkbook = GetObject("D:\Excel.xlsx") is not open in Excel you need to use CreateObject("Excel.Application") and open it.
Dim xlApp As Object
Set xlApp = CreateObject("Excel.Application")
Dim xlWorkbook As Object
Set xlWorkbook = xlApp.Workbooks.Open(FileName:="D:\Excel.xlsx") 'will open the workbook
xlApp.Visible = True 'make it false to open Excel invisible in the background
'your code here …
'in the end close workbook and Excel (espaciall if you had it invisible!)
xlWorkbook.Close SaveChanges:=False
xlApp.Quit 'close Excel
Option Explicit
Sub UpdateTables()
Const XLSX = "D:\Excel.xlsx"
Dim xlApp, wb, ws
Dim rngSearch, rngFound
Dim iLastRow As Long, n As Integer
' open spreadsheet
'Set xlApp = New Excel.Application
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
Set wb = xlApp.Workbooks.Open(XLSX, 1, 1)
Set ws = wb.Sheets(1)
iLastRow = ws.Cells(ws.Rows.Count, "A").End(-4162).Row 'xlUp
Set rngSearch = ws.Range("A2:A" & iLastRow)
' update tables
Dim doc As Document, tbl As Table, s As String
Set doc = ThisDocument
For Each tbl In doc.Tables
s = tbl.Cell(1, 1).Range.Text
s = Left(s, Len(s) - 2)
Set rngFound = rngSearch.Find(s, LookIn:=-4163, LookAt:=1) ' xlValues, xlWhole
If rngFound Is Nothing Then
MsgBox "'" & s & "' not found in table " & tbl.Title, vbExclamation
Else
tbl.Range.Cells(3).Range.Text = rngFound.Offset(0, 1)
n = n + 1
End If
Next
wb.Close False
xlApp.Quit
MsgBox n & " tables updated", vbInformation
End Sub
I have a macro that is to be used inside a macro I found on internet.
The second macro runs through all Excel files inside a folder:
Sub RunOnAllFilesInFolder()
Dim folderName As String, eApp As Excel.Application, fileName As String
Dim wb As Workbook, ws As Worksheet, currWs As Worksheet, currWb As Workbook
Dim fDialog As Object: Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
Set currWb = ActiveWorkbook: Set currWs = ActiveSheet
'Select folder in which all files are stored
fDialog.Title = "Select a folder"
fDialog.InitialFileName = currWb.Path
If fDialog.Show = -1 Then
folderName = fDialog.SelectedItems(1)
End If
'Create a separate Excel process that is invisibile
Set eApp = New Excel.Application: eApp.Visible = False
'Search for all files in folder [replace *.* with your pattern e.g. *.xlsx]
fileName = Dir(folderName & "\*.*")
Do While fileName <> ""
'Update status bar to indicate progress
Application.StatusBar = "Processing " & folderName & "\" & fileName
Set wb = eApp.Workbooks.Open(folderName & "\" & fileName)
'...
'YOUR CODE HERE
'...
wb.Close SaveChanges:=False 'Close opened worbook w/o saving, change as needed
Debug.Print "Processed " & folderName & "\" & fileName
fileName = Dir()
Loop
eApp.Quit
Set eApp = Nothing
'Clear statusbar and notify of macro completion
Application.StatusBar = ""
MsgBox "Completed executing macro on all workbooks"
End Sub
I made a macro that, based on three named cells in a file, finds the ranges and change the style of some other ranges.
Not all Excel files have all three named cells, so I need the code to work when the range is not valid.
I tried to use error handlers but I received the following error:
"Loop without Do"
I tried IF and else for when the range does not exist and also found errors.
My code:
Dim test As Worksheet
Dim rOutstandingR As Range
Dim rAdditionalDueR As Range
Dim rFollowingR As Range
Dim rOutstandingBorderR As Range
Dim rAdditionalDueBorderR As Range
Dim rFollowingBorderR As Range
Dim ORow As Long
Dim OCol As Long
Dim ARow As Long
Dim ACol As Long
Dim FRow As Long
Dim FCol As Long
Dim OutstandingTopBorderRange As Range
Dim OutstandingBottomBorderRange As Range
Dim OutstandingRightBorderRange As Range
Dim AdditionalDueTopBorderRange As Range
Dim AdditionalDueBottomRange As Range
Dim AdditinalDueRightBorderRange As Range
Dim FollowingTopBorderRange As Range
Dim FollowingBottomBorderRange As Range
Dim FollowingRightBorderRange As Range
Dim OutstandingTextRange As Range
Dim AdditionalDueTextRange As Range
Dim FollowingTextRange
With Range("A1:Z999")
'Setting up another range that may not exists within excel file and give an error
Set rOutstandingR = ActiveSheet.Range("Outstanding")
rOutstandingBorderR = rOutstandingR.Address
rOutstandingR.Select
‘more code in which I change format of cells based on range
'Setting up another range that may not exists within excel file and give an error
Set rAdditionalDueR = ActiveSheet.Range("AdditionalDue")
rAdditionalDueBorderR = rAdditionalDueR.Address
rAdditionalDueR.Select
‘more code in which I change format of cells based on range
'Setting up another range that may not exists within excel file and give an error
'Setting Up rFollowingR as Range for Following Variable
Set rFollowingR = ActiveSheet.Range("Following")
rFollowingBorderR = rFollowingR.Address
rFollowingR.Select
‘more code in which I change format of cells based on range
As you can imagine by the amount of ranges, there is a lot of code in between but it's only based on the three major ranges for the named cells "Outstanding", "AdditionalDue" and "Following".
I need that all the codes between ranges work and if the first range doesn't exist goes to validate then next and do the changes of format, etcetera.
I tried to put some error handlers (resume labels) but I wasn't able to fix it when I used the code above within the first macro due to the loop through all the files.
How can I put the error handlers so I could use this macro inside the one that runs over a folder of files.
There are two ways to handle this, however with the snippets provided it's not straightforward to test what you're working on. You may want to consider separating your code into multiple subs/functions.
This solution should be clean assuming that you want some type of handling code to run:
With range("A1:Z999")
'Setting up another range that may not exists within excel file and give an error
On Error GoTo OutstandingError
Set rOutstandingR = ActiveSheet.range("Outstanding")
rOutstandingBorderR = rOutstandingR.Address
rOutstandingR.Select
OutstandingResume:
'more code in which I change format of cells based on range
'Setting up another range that may not exists within excel file and give an error
On Error GoTo AdditionalDueError
Set rAdditionalDueR = ActiveSheet.range("AdditionalDue")
rAdditionalDueBorderR = rAdditionalDueR.Address
rAdditionalDueR.Select
AdditionalDueResume:
'more code in which I change format of cells based on range
'Setting up another range that may not exists within excel file and give an error
'Setting Up rFollowingR as Range for Following Variable
On Error GoTo FollowingError
Set rFollowingR = ActiveSheet.range("Following")
rFollowingBorderR = rFollowingR.Address
rFollowingR.Select
FollowingResume:
'more code in which I change format of cells based on range
GoTo Complete
OutstandingError:
'Error handling code here
Resume OutstandingResume
AdditionalDueError:
'Error handling code here
Resume AdditionalDueResume
FollowingError:
'Error handling code here
Resume FollowingResume
Complete:
This solution just bypasses the block entirely without any handling code:
With range("A1:Z999")
'Setting up another range that may not exists within excel file and give an error
On Error GoTo OutstandingResume
Set rOutstandingR = ActiveSheet.range("Outstanding")
rOutstandingBorderR = rOutstandingR.Address
rOutstandingR.Select
OutstandingResume:
'more code in which I change format of cells based on range
'Setting up another range that may not exists within excel file and give an error
On Error GoTo AdditionalDueResume
Set rAdditionalDueR = ActiveSheet.range("AdditionalDue")
rAdditionalDueBorderR = rAdditionalDueR.Address
rAdditionalDueR.Select
AdditionalDueResume:
'more code in which I change format of cells based on range
'Setting up another range that may not exists within excel file and give an error
'Setting Up rFollowingR as Range for Following Variable
On Error GoTo FollowingResume
Set rFollowingR = ActiveSheet.range("Following")
rFollowingBorderR = rFollowingR.Address
rFollowingR.Select
FollowingResume:
'more code in which I change format of cells based on range
If you'd like to go in a different direction, here is a function that returns a boolean for whether or not a named range exists. Using this you could refactor this to use conditionals instead of relying on error checking and line jumps.
Private Function BET_RangeNameExists(nname) As Boolean
Dim n As Name
BET_RangeNameExists = False
For Each n In ActiveWorkbook.Names
If UCase(n.Name) = UCase(nname) Then
BET_RangeNameExists = True
Exit Function
End If
Next n
End Function
Taken from https://bettersolutions.com/excel/named-ranges/vba-named-range-exists.htm
I've got a manual for a machine that i need to replace a large amount of part numbers with updated ones (17624 numbers). Ive got an excel doc that ive combiled with row A with old numbers and row B with the new numbers. The manual is in word (2016). Ive tried some code that i found but im unable to get it to work. Ive created a smaller excel doc with only a small list of numbers for testing reasons.
Sub findandreplace()
Dim xlApp As Object
Dim xlWB As Object
Dim xlWS As Object
Dim i As Integer, j As Integer
Dim lastRow As Integer
Set xlApp = CreateObject("Excel.Application")
Set xlWB = xlApp.Workbooks.Open("C:\Users\lforget\Downloads\process_batch_folder_addin\list.xlsx")
Set xlWS = xlWB.Worksheets("Sheet1") 'Replace String with your Worksheet Name
lastRow = 1
For i = 1 To ThisDocument.Words.Count - 1 Step 1
For j = 1 To lastRow Step 1
ThisDocument.Words(i) = Replace(ThisDocument.Words(i), xlWS.Cells(j, 1).Value, xlWS.Cells(j, 2).Value)
Next j
Next i
Set xlWS = Nothing
xlWB.Close True
Set xlWB = Nothing
xlApp.Quit
Set xlApp = Nothing
End Sub
Runtime error 6
ived tried reducing the amount of lines in the excel doc but that hasnt made any difference
I am trying to write a PowerPoint VB application which needs to display certain values from a text file in a fixed format.
When I (manually) open that text file as a csv file in Excel, I get the required values in fixed cells and I know how continue from there by VBA.
What I do not know is how to create the Excel spreadsheet using a macro in PowerPoint.
Also, I want to make sure that the parameters for opening the file (using space as delimiter; multiple spaces count as one) are defined in the macro so that I do not have to rely on current local settings.
Thanks in advance for any idea or reference.
use ~.OpenText
it Supports consecutive delimiter
2.Use text file not with .csv but with .txt extension
Excel fails to load a text with other delimiter if it's extension is '.csv'
Following macro reads a text file with delimiters of space character and copies the Excel table to Powerpoint Table on a Slide.
Full code:
Sub ReadCSV()
Dim xlsApp As Excel.Application
Dim xlsWb As Excel.Workbook
Dim xlsSht As Object 'Excel.Worksheet
Dim rng As Object 'Excel.Range
Dim Target As String
On Error GoTo Oops
'Set xlsApp = New Excel.Application
Set xlsApp = CreateObject("Excel.Application")
xlsApp.Visible = True
Target = ActivePresentation.Path & "\test_space.txt"
'Below don't support consecutive delimiters
'Set xlsWb = xlsApp.Workbooks.Open(FileName:=Target, Format:=3)
'File Extension .CSV won't work here. .TXT works.
xlsApp.Workbooks.OpenText FileName:=Target, Origin:=2, StartRow:=1, _
DataType:=1, ConsecutiveDelimiter:=True, Space:=True, Local:=True
Set xlsWb = xlsApp.ActiveWorkbook
Set xlsSht = xlsWb.Worksheets(1)
Dim sld As Slide
Dim shp As Shape
Dim tbl As Table
Dim numRow As Long, numCol As Long
Dim r As Long, c As Long
Set rng = xlsSht.UsedRange
numRow = rng.Rows.Count
numCol = rng.Columns.Count
With ActivePresentation
Set sld = .Slides.Add(.Slides.Count + 1, ppLayoutBlank)
End With
Set shp = sld.Shapes.AddTable(numRow, numCol, 100, 100, 200, 150)
shp.Name = "Table"
Set tbl = shp.Table
'Copy cell values from Excel Table to Powerpoint Table
For r = 1 To numRow
For c = 1 To numCol
tbl.Cell(r, c).Borders(ppBorderBottom).ForeColor.RGB = rgbBlack
With tbl.Cell(r, c).Shape.TextFrame
If r > 1 Then .Parent.Fill.ForeColor.RGB = rgbWhite
.VerticalAnchor = msoAnchorMiddle
.TextRange = rng.Cells(r, c)
.TextRange.ParagraphFormat.Alignment = ppAlignCenter
End With
Next c
Next r
xlsWb.Close False
Oops:
If Err.Number Then MsgBox Err.Description
'If Excel App remains in the system process, Excel App won't respond and run again.
If Not xlsApp Is Nothing Then xlsApp.Quit: Set xlsApp = Nothing
End Sub