I'm using VBA to search for a given word (Ex, Cell A1) in a Word document, then replace that word in the Word doc with a value that corresponds to the cell beside it (cell B1).
Most instances of the words are only found once in the document, but I have some that repeat throughout. For these repeated ones, only the first instance is replaced and the rest aren't. I tried to find some solutions to this, but I've really only come across Excel-specific ones.
Sub ReplaceAnnual()
'
'
'Declare Variables as Objects
Dim oCell As Integer
Dim from_text As String, to_text As String
Dim WA As Object
Dim ws As Object
Dim wb As Workbook
Dim IntialName As String
Dim fileSaveName As Variant
'Open workbook and setting to the wb object for further use
Set wb = Workbooks.Open("C:\Pathway\Point_Estimates.xlsx")
'Set up Excel Application: sets currently open file as object
Set ws = Workbooks("Point_Estimates")
'Set up Word Application
Set WA = CreateObject("Word.Application")
WA.Visible = True
'Opens Pre-Saved Document & activates it to use
WA.Documents.Open "C:\Pathway\Filename.dotm"
WA.Activate
'Tells which cells to find and replace elements
For oCell = 2 To 75
from_text = Sheets("Values").Range("A" & oCell).Value
to_text = Sheets("Values").Range("B" & oCell).Value
'Specifies which application to work inside
With WA.ActiveDocument
Set myRange = .Content
With myRange.Find
.Execute FindText:=from_text, ReplaceWith:=to_text, Replace:=1
End With
End With
Next oCell
'Activate Excel Worksheet
ws.Activate
'Declare where to find numbers for naming file (e.g. 2020)
InitialName = "Point_Estimates_" & Range("B2")
'Prompt dialog box and save
fileSaveName = Application.GetSaveAsFilename(InitialFileName:=InitialName, _
fileFilter:="Excel Files (*.xls), *.xls")
If fileSaveName <> False Then
MsgBox "Save as " & fileSaveName
End If
'
'
End Sub
It ends with a prompt to save the Excel file with a specified name.
Any tips or help on tweaking this would be greatly appreciated!
Related
My goal is to use two dropdown menus (DM) within a workbook to open a filled-out document.
The DM 1 is to select which row of data will be merged.
The DM 2 is to select which template is being used.
I have separate code that highlights the selected row and opens the document.
Set doc = appWD.ActiveDocument gives me
error 4248 This command is not available because no document is open.
The template is open when I receive this error.
For Context:
Open_LPA_Template, run by itself, does open the Word document selected from the DM 2.
Select_Parcel, run by itself, does highlight the row of data selected from the DM 1.
Sub Run_Mail_Merge_LPA()
Dim doc As Word.Document
Dim appWD As Object
Dim wb As Workbook
Dim ws As Worksheet
Dim ws2 As Worksheet
Dim tbl As ListObject
Dim row As ListRow
Dim searchValue As String
Dim searchRange As Range
Dim foundCell As Range
' Get references to the workbook and worksheets
Set wb = ThisWorkbook
Set ws = wb.Worksheets(1)
Set ws2 = wb.Worksheets(2)
' Create an instance of the Word application
Set appWD = CreateObject("Word.Application")
' Open the Word document that has been selected in DM 2
Open_LPA_Template
' Select_Parcel's CODE: Select the Row of Data from DM 1 for the Mail Merge
ws2.Select
' Select cell D3 in worksheet 2
ws2.Range("D3").Select
' Store the value in D3 of worksheet 2 in a variable
searchValue = ws2.Range("D3").Value
' Set the search range to the entire column A of worksheet 1
ws.Select
Set searchRange = ws.Range("A:A")
' Use the Find method to search for the search value in the search range
Set foundCell = searchRange.Find(searchValue)
If Not foundCell Is Nothing Then
' If a match is found, select the cell
foundCell.Select
ActiveCell.EntireRow.Select
Else
' If no match is found, print a message
Debug.Print "Value not found in column A"
End If
' MAIL MERGE CODE: Set the active document to the Word document that was opened
Set doc = appWD.ActiveDocument
' Perform the mail merge
doc.MailMerge.MainDocumentType = wdFormLetters
doc.MailMerge.OpenDataSource _
Name:=row.Range, _
ConfirmConversions:=False, ReadOnly:=False, LinkToSource:=True, _
AddToRecentFiles:=False, PasswordDocument:="", PasswordTemplate:="", _
WritePasswordDocument:="", WritePasswordTemplate:=""
doc.MailMerge.Execute
End Sub
Sub Open_LPA_Template()
Dim wb As Workbook
Dim ws As Worksheet
Dim ws2 As Worksheet
Dim MainPath As String
Dim MainPath2 As String
Dim MainPath3 As String
Dim MainPath4 As String
Dim MainPath5 As String
Dim MainPath6 As String
Dim Parcel As String
Dim fileName As String
Dim FullPath As String
Dim mWord As Object
Set wb = ThisWorkbook
Set ws = wb.Worksheets(1)
Set ws2 = wb.Worksheets(2)
Set appWD = CreateObject("Word.Application")
appWD.Visible = True
MainPath = "C:\Users\ME\Dropbox (ORC)\Desktop\Templates\LPA\"
MainPath2 = "C:\Users\USER1\Dropbox (ORC)\Desktop\Templates\LPA\"
MainPath3 = "C:\Users\USER2\Dropbox (ORC)\Desktop\Templates\LPA\"
MainPath4 = "C:\Users\USER3\Dropbox (ORC)\Desktop\Templates\LPA\"
MainPath5 = "C:\Users\USER4\Dropbox (ORC)\Desktop\Templates\LPA\"
MainPath6 = "C:\Users\USER5\Dropbox (ORC)\Desktop\Templates\LPA\"
fileName = ws2.Range("E3")
' Check if the file exists at the first path
If Dir(MainPath & fileName & ".docx") <> "" Then
FullPath = MainPath & fileName & ".docx"
ElseIf Dir(MainPath2 & fileName & ".docx") <> "" Then
' If the file does not exist at the first path, check the second path
FullPath = MainPath2 & fileName & ".docx"
ElseIf Dir(MainPath3 & fileName & ".docx") <> "" Then
' If the file does not exist at either of the first two paths, check the third path
FullPath = MainPath3 & fileName & ".docx"
ElseIf Dir(MainPath4 & fileName & ".docx") <> "" Then
' If the file does not exist at any of the first three paths, check the fourth path
FullPath = MainPath4 & fileName & ".docx"
ElseIf Dir(MainPath5 & fileName & ".docx") <> "" Then
' If the file does not exist at any of the first four paths, check the fifth path
FullPath = MainPath5 & fileName & ".docx"
Else
' If the file does not exist at any of the first five paths, use the sixth path
FullPath = MainPath6 & fileName & ".docx"
End If
appWD.Documents.Open (FullPath)
There are six paths because it could be accessed/used by six people who get to the shared Word documents through their own computers.
Since you are creating a new instance of Word via
Set appWD = CreateObject("Word.Application")
That Word instance has no open documents. You need to open the relevant document and address it via code like:
Set doc = appWD.Documents.Open(Filename:="C:\Users\Aaron Bradow\Documents\Mail Merge Document.docx", AddToRecentFiles:=False, ReadOnly:=True)
The problem is that you create two separate instances of Word Application in the code and try to access a Document instance opened in another Word Application instance/process. If you want to use the ActiveDocument property you need to deal with a single Word Application instance in the code. So, you may pass a created Word Application instance as a parameter to the method to open files.
Be aware, the Documents.Open function from the Word object model opens the specified document and adds it to the Documents collection. It also returns a Document object which can be used instead of the ActiveDocument property in the code.
Sub OpenDoc()
Dim doc As Word.Document
Set doc = Documents.Open FileName:="C:\MyFiles\MyDoc.doc"
End Sub
This is the first week I learn vba so bear with me if I have a lot of questions;-)
So I have two folders, one folder contains the templates I need to update, the other contains the reports that the updates will be copied from. Cell A1 in each template contains the code that is specific to that BU. I need vba to find the code in the file names in the report folder and open that report. The problem is that the report names have different lengths, eg. it's named as XXX region_code_XXXXXXXXXXX, there can be any number of "X" before and after the code.
Sub Macro1()
Set fso = CreateObject("scripting.filesystemobject")
Set ff = fso.getfolder("C:\Users\35264\summary\test")
For Each file In ff.Files
Workbooks.Openfile
Set wbk2 = ActiveWorkbook
Sheets("Summary").Select
Range("A1").Select
rngX = Range("A1").Value
Now I need to find rngX in the file names in the report folder... I can't figure out how. Let me know if anyone can help! Thank you!
I am learning how to use dir function. I think it will be helpful to get the names of the reports first.
Combine the FileSystemObject Object With the Dir Function
Dir cannot be used in nested Do...Loops.
Using the FileSystemObject object, it opens files in one folder and uses the information in it to open specific files in another folder by using the Dir function. For each combination, it prints their names to the immediate window and closes each file without saving changes.
A better way to do this would be to write the file paths of the first folder to an array by using the Dir function and then loop through the elements of the array to open each file... etc.
Option Explicit
Sub PrintTemplatesAndReports()
' Templates
Const tFolderPath As String = "C:\Users\35264\summary\templates\"
Const tWorksheetName As String = "Summary"
Const rFilePatternAddress As String = "A1"
Const tFileExtensionLeft As String = "xls"
' Reports
Const rFolderPath As String = "C:\Users\35264\summary\reports\"
Const rFileExtensionPattern As String = ".xls*"
' 1st Worbook (ThisWorkbook)
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FolderExists(tFolderPath) Then Exit Sub
If Not fso.FolderExists(rFolderPath) Then Exit Sub
Dim fsoFolder As Object: Set fsoFolder = fso.Getfolder(tFolderPath)
' Templates (using the FileSystemObject object)
Dim fsoFile As Object
Dim twb As Workbook, tws As Worksheet
Dim tExtension As String, tFilePath As String
' Report (using Dir)
Dim rwb As Workbook
Dim rFilePattern As String, rFileName As String, rFilePath As String
' Counters
Dim ttCount As Long, tCount As Long, rCount As Long
For Each fsoFile In fsoFolder.Files
ttCount = ttCount + 1
tExtension = fso.GetExtensionName(fsoFile)
If InStr(1, tExtension, tFileExtensionLeft, vbTextCompare) = 1 Then
tCount = tCount + 1
tFilePath = tFolderPath & fsoFile.Name
' 2nd Workbook (Template)
Set twb = Workbooks.Open(tFilePath)
On Error Resume Next
Set tws = twb.Worksheets(tWorksheetName)
On Error GoTo 0
If Not tws Is Nothing Then
rFilePattern = CStr(tws.Range(rFilePatternAddress).Value)
rFileName = Dir(rFolderPath, "*" & rFilePattern _
& "*" & rFileExtensionPattern)
Do Until Len(rFileName) = 0
rCount = rCount + 1
rFilePath = rFolderPath & rFileName
' 3rd Workbook (Report)
Set rwb = Workbooks.Open(rFolderPath, rFileName)
' Do your thing, e.g.:
Debug.Print twb.Name, rwb.Name
rwb.Close SaveChanges:=False
rFileName = Dir ' next report
Loop
Set tws = Nothing
End If
twb.Close SaveChanges:=False
End If
Next fsoFile ' next template
MsgBox "Template files processed: " & tCount & "(" & ttCount & ")" _
& vbLf & "Report files processed: " & rCount & "(" & tCount & ")", _
vbInformation
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.
In my folder, there is AA.bmp, AA.txt, BB.bmp and BB.txt
I am able to extract the data for AA.txt and BB.txt in a separate worksheet.
Am I also able to insert AA.bmp in the same sheet as AA.txt, and BB.bmp in the same sheet as BB.txt?
Sub ExtractData()
iPath = "C:\Users\NHWD78\Desktop\Report\Radiated Immunity\"
ifile = Dir(iPath & "*.txt")
Do While Len(ifile)
Sheets.Add , Sheets(Sheets.Count), , iPath & ifile
ifile = Dir
Range("A10:B10, A16:B19").Copy Destination:=Sheets(Sheets.Count).Range("A1")
Application.CutCopyMode = False
Range("A6:K600").Clear
Columns.AutoFit
Loop
End Sub
I have search throughout the website but only found a way to insert a fixed image with image name.
This will answer your query, its more of a solution than an answer which is not what this site is for, but take the time to read through it as it should be educationally useful too.
You are trying to parse a folder that has content similar to below:-
The result os for these to be in an Excel workbook, with a worksheet containing the text and image for each group (AA, BB, and CC)
First step I would take is to use Microsoft Scripting Runtime, this makes parsing the folder a lot easier. To enable this, within the VBA environment (known as the IDE), select 'Tools' > 'References...', scroll down to 'Microsoft Scripting Runtime' and tick it, then click 'OK' to close the dialog box.
That allows us to the File System Object, which is a very useful file and folder manipulation and interrogation feature set.
Firstly we care most about the *.txt files so lets begin by looping through them:-
Dim FSO As New FileSystemObject
Dim Fldr As Folder
Dim Fl As File
'First we set Fldr to be the folder we care about
Set Fldr = FSO.GetFolder("C:\Users\garye\Desktop\Work")
'Then start a loop to look through each file in the folder
For Each Fl In Fldr.Files
'If the files ends in .txt then we care about it (UCASE used to make it case insensitive)
If Right(UCase(Fl.Name), 4) = ".TXT" Then
'We have found a file
End If
'Do events returns the processor to the system for any other items to be process
'very useful in a loop on a Windows based machine to stop resource hogging and lock ups
DoEvents
Next
Set Fldr = Nothing
Next on the discovery of a text file we want to create a worksheet and import the text. For the sake of this example, it will all be done in a new workbook as well.
Dim WkBk As Workbook
Dim WkBk_Tmp As Workbook
Dim WkSht As Worksheet
Dim WkSht_Tmp As Worksheet
Dim StrName As String
'Create a new workbook
Set WkBk = Application.Workbooks.Add
'...
'Collect the name (i.e. AA from AA.txt)
StrName = Left(Fl.Name, Len(Fl.Name) - 4)
'Create a new worksheet in out new workbook
Set WkSht = WkBk.Worksheets.Add
'Change the worksheet name to the file name
WkSht.Name = StrName
'Open the file in Excel
Set WkBk_Tmp = Application.Workbooks.Open(Fl.Path)
Set WkSht_Tmp = WkBk_Tmp.Worksheets(1)
'Copy its contents into out worksheet
WkSht_Tmp.Cells.Copy WkSht.Cells
Set WkSht_Tmp = Nothing
'Close the file
WkBk_Tmp.Close 0
Set WkBk_Tmp = Nothing
Next we want to insert the image if it is there:-
Dim Rng As Range
'...
'See it a bmp file exists (i.e. AA.bmp)
If FSO.FileExists(Fldr.Path & "\" & StrName & ".bmp") Then
'This get the bottom row of data as a position to insert the image
Set Rng = WkSht.Range(WkSht.Range("A1").End(xlDown).Address).Next(2, 0)
'Add the picture
WkSht.Shapes.AddPicture Fldr.Path & "\" & StrName & ".bmp", msoFalse, msoCTrue, Rng.Left, Rng.Top, -1, -1
Set Rng = Nothing
End If
If we put all the above together it looks as below, hopefully this has been education in what is happening in the code, some good practices, how to approaching a task.
Option Explicit
Sub ExtractData()
Dim FSO As New FileSystemObject
Dim Fldr As Folder
Dim Fl As File
Dim WkBk As Workbook
Dim WkBk_Tmp As Workbook
Dim WkSht As Worksheet
Dim WkSht_Tmp As Worksheet
Dim StrName As String
Dim Rng As Range
'Create a new workbook
Set WkBk = Application.Workbooks.Add
'First we set Fldr to be the folder we care about
Set Fldr = FSO.GetFolder("C:\Users\garye\Desktop\Work")
'Then start a loop to look through each file in the folder
For Each Fl In Fldr.Files
'If the files ends in .txt then we care about it (UCASE used to make it case insensitive)
If Right(UCase(Fl.Name), 4) = ".TXT" Then
'Collect the name (i.e. AA from AA.txt)
StrName = Left(Fl.Name, Len(Fl.Name) - 4)
'Create a new worksheet in out new workbook
Set WkSht = WkBk.Worksheets.Add
'Change the worksheet name to the file name
WkSht.Name = StrName
'Open the file in Excel
Set WkBk_Tmp = Application.Workbooks.Open(Fl.Path)
Set WkSht_Tmp = WkBk_Tmp.Worksheets(1)
'Copy its contents into out worksheet
WkSht_Tmp.Cells.Copy WkSht.Cells
Set WkSht_Tmp = Nothing
'Close the file
WkBk_Tmp.Close 0
Set WkBk_Tmp = Nothing
'See it a bmp file exists (i.e. AA.bmp)
If FSO.FileExists(Fldr.Path & "\" & StrName & ".bmp") Then
'This get the bottom row of data as a position to insert the image
Set Rng = WkSht.Range(WkSht.Range("A1").End(xlDown).Address).Next(2, 0)
'Add the picture
WkSht.Shapes.AddPicture Fldr.Path & "\" & StrName & ".bmp", msoFalse, msoCTrue, Rng.Left, Rng.Top, -1, -1
Set Rng = Nothing
End If
Set WkSht = Nothing
End If
'Do events returns the processor to the system for any other items to be process
'very useful in a loop on a Windows based machine to stop resource hogging and lock ups
DoEvents
Next
Set Fldr = Nothing
Set WkBk = Nothing
MsgBox "Done!"
End Sub
Worksheet.Shapes.AddPicture will do it. Example below: -
Public Sub Sample()
Dim WkBk As Workbook
Dim WkSht As Worksheet
Dim Ole As Object
Set WkBk = ThisWorkbook
Set WkSht = WkBk.Worksheets(1)
WkSht.Shapes.AddPicture "C:\Users\garye\Desktop\AA.bmp", msoFalse, msoCTrue, 0, 0, -1, -1
Set WkSht = Nothing
Set WkBk = Nothing
End Sub
My issue is after I have imported a table from Microsoft Word into Excel by creating an OLEObject, it won't let me copy and paste the table into excel. It continually keeps pasting whatever was last copied on my clipboard into the first cell. Currently my code asks the user for the file name, opens that file as an OLEObject in the active excel sheet, and then pastes the incorrect information into cell A1. It's not copying and pasting what's inside the Word OLEObject.
Sub Macro1()
Dim FName As String, FD As FileDialog
Dim ExR As Range
Set FD = Application.FileDialog(msoFileDialogOpen)
FD.Show
If FD.SelectedItems.Count <> 0 Then
FName = FD.SelectedItems(1)
Else
Exit Sub
End If
ActiveSheet.OLEObjects.Add(fileName:=FName, Link:=False, DisplayAsIcon:=False).Select
Selection.Verb Verb:=xlPrimary
Range("A1").Select
ActiveSheet.Paste
End Sub
Thank you!
From Word to Excel, should be something like this.
Sub ImportFromWord()
'Activate Word Object Library
'Dim WordApp As Word.Application
Dim WordDoc As Word.Document
Set WordApp = CreateObject("word.application") ' Open Word session
WordApp.Visible = False 'keep word invisible
Set WordDoc = WordApp.Documents.Open("C:\Users\your_path_here_\WordFile.docx") ' open Word file
'copy third row of first Word table
WordDoc.Tables(1).Rows(3).Range.Copy
'paste in Excel
Range("A1").PasteSpecial xlPasteValues
WordDoc.Close 'close Word doc
WordApp.Quit ' close Word
End Sub
Or this.
Sub GetTables()
FName = Application _
.GetOpenFilename("Word Files (*.doc), *.doc")
Set WordObject = GetObject(FName)
First = True
RowCount = 2
For Each Tble In WordObject.tables
For i = 1 To 22
If First = True Then
Data = Tble.Rows(i).Cells(1).Range
'Remove cell markers
Cells(1, i) = Left(Data, Len(Data) - 2)
End If
Data = Tble.Rows(i).Cells(2).Range.Text
'Remove cell markers
Cells(RowCount, i) = Left(Data, Len(Data) - 2)
Next i
RowCount = RowCount + 1
First = False
Next Tble
WordObject.Close savechanges = False
End Sub
Using the code from the link How to preserve source formatting while copying data from word table to excel sheet using VB macro? , I've only been able to get the code to work when the macro pastes my Word table in a whole new separate workbook. When clicking a command button that's within the excel workbook that I want to import the Word table to, the table never pastes into the sheet called "Scraping Sheets" I've messed around with the code, but the closest thing I could get was placing the entire table into one cell with all formatting lost.
Private Sub CommandButton22_Click()
Dim oWordApp As Object, oWordDoc As Object
Dim FlName As String
Dim tbl As Object
FlName = Application.GetOpenFilename("Word files (*.Doc*),*.Doc*", , _
On Error Resume Next
Set oWordApp = GetObject(, "Word.Applicaton")
If Err.Number <> 0 Then
Set oWordApp = CreateObject("Word.Application")
End If
Err.Clear
On Error GoTo 0
oWordApp.Visible = True
Set oWordDoc = oWordApp.Documents.Open(FlName)
Set tbl = oWordDoc.Tables(1)
Dim wb As Workbook, ws As Worksheet
Set wb = Workbooks.Open(""C:\Users\xxxx\Desktop\292 Int'l_Weekly_Win_Loss_YYYY MM DD TEMPLATE.xlsm"")
Set ws = wb.Sheets("Scraping Sheet")
tbl.Range.Copy
ws.Range("A1").Activate
ws.Paste
MsgBox "Successfully Added File!"
End Sub