VBA to find specific text in word doc and copy this text from word doc into a cell in excel - excel

Hello stackoverflow community.
What I'm doing until now, is I manually copy a price from the word document, which I previously open, and paste it into an Excel sheet.
It is the only .docx file opened at the time on computer, so we just need to find the price in currently opened word file.
I'd like U to help me automate this task.
This picture shows the part of the document from where I copy the price.
In this example it's 605.000. But I don't know the price before I check it in the word file.
The word file is a place where I learn what the price is.
The selected text occurs only once in the whole document therefore I need VBA to copy what's after "brutto w kwocie " and up to the first coma.
Yes - only the amount of money without decimal values, because they're always ,00.
But not only seven signs, because if I had apartment price 1.250.000 then the macro that copies only 7 signs wouldn't work.
Sub Find_Price()
'Variables declaration
Dim WordApp As Word.Application
Dim WordDoc As Word.Document
Dim TextToFind As String
Dim ApartmentPrice As String
Dim Rng As Word.Range
Application.ScreenUpdating = False
'This is the text I'm looking for in .ActiveDocument
TextToFind = "brutto w kwocie "
'Start Word and create an object
'Set WordApp = CreateObject("Word.Application")
'Reference already opened Word document from excel VBA console
Set WordApp = GetObject(, "Word.Application")
WordApp.Application.Visible = True
Set Rng = WordApp.ActiveDocument.Content
'Set WordDoc = WordApp.ActiveDocument 'I don't know how to finish this line
Rng.Find.Execute FindText:=TextToFind, Forward:=True
'what this "Forward:=True" means??
If Rng.Find.Found Then
If Rng.Information(wdWithInTable) Then
'I don't know how to write this part of the code.
'Please don't remove my question again - I've researched 16h for this info.
MsgBox "Price is " & ApartmentPrice & " pln."
End If
Else
MsgBox "Apartment price was not found!"
End If
Set ws = ActiveSheet 'currently opened sheet on currently opened.xlsm file
ws.Range("E27").Activate
ws.Paste
End Sub
Then I need to strip the number from this ridiculous dot in the middle of the amount, so please help me clear 605.000 into 60500 or 1.250.000 into 1250000.
When I have this number (the price) in my clipboard, I need to paste it into currently opened excel file, into .activesheet (because the name of the excel file and excel sheet will change many times a day).
But the destination cell will always be E27 - it will never change.
Thank you guys for all the help.
EDIT 24.01.2020
This is the above mentioned code amended by me to my best abilities.
Sub Find_Corrected()
'Variables declaration
'Dim WordApp As Object
Dim WordApp As Word.Application
'Dim WordDoc As Object
Dim WordDoc As Word.Document
Dim TextToFind As String
Dim ApartmentPrice As String
Dim Rng As Word.Range
Application.ScreenUpdating = False
'This is the text I'm looking for in .ActiveDocument
TextToFind = "brutto w kwocie "
'Start Word and create an object
'Set WordApp = CreateObject("Word.Application")
'Reference already opened Word document from excel VBA console
Set WordApp = GetObject(, "Word.Application")
Set WordDoc = WordApp.ActiveDocument
Set Rng = WordApp.ActiveDocument.Content
WordApp.Application.Visible = True
'Set WordDoc = WordApp.Documents.Open(FilePath & "Form1.docx")
'Set WordDoc = WordApp.ActiveDocument 'I don't know how to finish this line :-(
Rng.Find.Execute FindText:=TextToFind, Forward:=True
'what this "Forward:=True" means??
With Rng.Find
.Text = "brutto w kwocie "
.Execute
If .Found = True Then
Rng.MoveEnd wdWord, 3
Rng.Copy
MsgBox "Copied value equals " & Rng.Value & " Roesler conquers."
Else
MsgBox "Requested range was not found!"
End If
End With
'Set ws = ActiveSheet ' currently opened sheet on currently opened.xlsm file
'ws.Range("E27").Activate
'ws.Paste
End Sub
And this is the error it returns.

You can use the same method that I used in an answer to another of your questions.
Create a range, set it equal to the whole document, search along the range, move until your desired stop range, then move the start of the range up to your numbers.
Dim srchRng as Range
Set srchRng = ActiveDocument.Content
With srchRng.Find
.Text = "brutto w kwocie "
.Execute
If .Found = True Then
Dim numberStart as Long
numberStart = Len(srchRng.Text) + 1
srchRng.MoveEndUntil Cset:=","
Dim myNum as String
myNum = Mid(srchRng.Text, numberStart)
End If
End With

Related

Find and copying text highlighted in a specific color

Hi I have a code (see below) that is working like a charm to find and copy text from a specific style and paste it in another document. It is in an excel file because I preferred this option to share with friends that would only need to click in the button, chose the input file and save as their preferred output file name.
Now I'm trying without success to perform the same task with text highlighted in a specific color (e. Turquoise). Please find below the code that is working with a specific word or style, I made some experiences with code I found here and there, but all I could get was to copy all highlighted text instead of my choice of color. See below. Any help is much appreciated.
Note on Edit: The code below is the closer I get to the desired result. It was a little chaotic due to my try and error attempts.
' Objects
Dim wrdApp, objWord As Object
Dim wrdDoc, newwrdDoc As Object
Dim myPath As String, myPath1 As String
Dim folderPath As String
Dim myFile As String
Dim numberStart As Long
Dim Rng, srchRng As Excel.Range
'Dim objDoc As Document, objDocAdd As Document
Dim objRange As Range
Dim strFindColor As String
Dim highliteColor As Variant
Dim i As Long
' Close MS Word if it's already opened
On Error Resume Next
Set objWord = GetObject(, "Word.Application")
If Not objWord Is Nothing Then
objWord.Quit SaveChanges:=0
Set objWord = Nothing
End If
'Defining input file name
myFile = Application.GetOpenFilename()
'Open MS Word
Set wrdApp = CreateObject("Word.Application")
wrdApp.Visible = True
' Folder Location
myPath = Application.ThisWorkbook.Path & "\"
' Input File
Set wrdDoc = wrdApp.Documents.Open(myFile)
' Output File
Set newwrdDoc = wrdApp.Documents.Add
myPath1 = Application.GetSaveAsFilename(FileFilter:="Word files(*.docx),*.docx")
' Text you want to search
'Dim FindWord As String
'Dim result As String
'FindWord = ""
highliteColor = Array(wdTurquoise)
'Style
'mystyle = wdTurquoise
'Defines selection for Word's find function
wrdDoc.SelectAllEditableRanges
' Find Functionality in MS Word
For i = LBound(wdTurquoise) To UBound(wdTurquoise)
objDoc.Activate
Selection.HomeKey Unit:=wdStory
objRange.Collapse wdCollapseEnd
With wrdDoc.ActiveWindow.Selection.Find
.HighlightColorIndex = wdTurquoise
.Highlight = True
.Forward = True
.Wrap = wdFindStop
objRange = Selection.Range
objDocAdd.Range.InsertAfter objRange & vbCr
Selection.Collapse wdCollapseEnd
End With
Next
' Execute find method
wrdDoc.ActiveWindow.Selection.Find.Execute
' Store Selected text
result = wrdDoc.ActiveWindow.Selection.Text
' Check if result contains non-blank text
If Len(result) > 1 Then
' -------------------------------------------------------------
' Loop through multiple find content (Find All functionality)
' -------------------------------------------------------------
While wrdDoc.ActiveWindow.Selection.Find.Found
wrdDoc.ActiveWindow.Selection.Copy
'Activate the new document
newwrdDoc.Activate
'New Word Doc
Set Rng = newwrdDoc.Content
Rng.Collapse Direction:=wdCollapseEnd
Rng.Paste
'Word Document
wrdDoc.Activate
wrdDoc.ActiveWindow.Selection.Find.Execute
Wend
' If style not found
Else
MsgBox "Text Not Found"
End If
'Close and don't save application
wrdDoc.Close SaveChanges:=False
'Save As New Word Document
newwrdDoc.SaveAs myPath1
newwrdDoc.Close SaveChanges:=True
'Close all word documents
wrdApp.Quit SaveChanges:=0
'Message when done
MsgBox "Task Accomplished"
End Sub

Pull particular Excel cell value into Word document using Word VBA

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

How to Copy ALL InlineShapes from Word to Excel?

I'm trying to copy all inline shapes from a word document to excel sheet.
The Word Document has multiple pages, with multiple tables with images in them.
The code I'm using is:
Sub imageExtract()
Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document
Dim shpCurr As InlineShape
Dim i As Long
Set wrdApp = CreateObject("Word.Application")
Set wrdDoc = wrdApp.Documents.Open("C:\Temp\01.docx")
For Each shpCurr In wrdDoc.InlineShapes
shpCurr.Range.CopyAsPicture
Sheet10.Range("A" & i).PasteSpecial
i = i + 1
Next shpCurr
End Sub
Can someone explain to me why it is working for all the shapes in the first page of the Word document, and doesn't work for the shapes from another pages?
wrdDoc.InlineShapes.Count shows the real number of the shapes in the doc, so the loop is compleate
I've tried to cut and paste each shape to the first page before .CopyAsImage, with no sucsess.
I also tried to loop through each table and reference to the table's inline shapes ( "wrdDoc.tbl.InlineShapes"), with no sucsess.
If I manualy move a picture from (let's say) Page2 to Page1 and run the code again, this picture is copied.
If the problem is not the initial setting of the variable i, as I have mentioned in my comment above, then maybe you should try this code because not all shapes in a Word document are necessarily InlineShapes. The definition of InlineShapes in Word is they reside on their own paragraph. The other possibility for Shapes in a Word document are they have wrapping text and are anchored to some other place in the document. The significance here for InlineShapes and Floating Shapes is they each have to be referenced separately.
Of course you have mentioned that the InlineShapes count matches to what you expect but ... who knows ... maybe try this:
Sub imageExtract()
Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document
Dim iShp As Word.InlineShape, shp As Word.Shape
Dim i As Long
Set wrdApp = CreateObject("Word.Application")
Set wrdDoc = wrdApp.Documents.Open("C:\Temp\01.docx")
If wrdDoc.Shapes.Count > 0 Then
For i = 1 To wrdDoc.Shapes.Count
Set shp = wrdDoc.Shapes(i)
shp.ConvertToInlineShape
Next
End If
If wrdDoc.InlineShapes.Count > 0 Then
For i = 1 To wrdDoc.InlineShapes.Count
Set iShp = wrdDoc.InlineShapes(i)
iShp.Range.CopyAsPicture
Sheet10.Range("A" & i).PasteSpecial
Next
End If
End Sub
UPDATE
After you sent me the files I was able to figure out that the problem is with Excel's PasteSpecial and if executed too many times an error 1004 PasteSpecial method of Range class failed because for some unknown reason something clears the clipboard and attempting to paste an empty clipboard generates the error.
I altered your code to use Word's Selection method to copy the images versus a Range method that was in your original code and that took care of the problem ... strange but it works. I also added some other code so that Word is properly closed out when the routine ends.
Sub imageExtract()
Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document
Dim shpCurr As Word.InlineShape
Dim i As Long
On Error GoTo errHandler
Set wrdApp = CreateObject("Word.Application")
wrdApp.Visible = True
Set wrdDoc = wrdApp.Documents.Open(ThisWorkbook.Path & "\01.docx")
i = 1
wrdDoc.Activate
Debug.Print wrdDoc.InlineShapes.Count
'On Error Resume Next
For Each shpCurr In wrdDoc.InlineShapes
shpCurr.Select
wrdApp.Selection.CopyAsPicture
Sheet10.Range("A" & i).PasteSpecial xlPasteAll
i = i + 1
Next
'the following is copying only one character which will clear the clipboard
'and prevent the message about wanting to save the last thing copied
wrdApp.Selection.EndKey wdStory
wrdApp.Selection.MoveStart wdCharacter, -1
wrdApp.Selection.Copy
wrdDoc.Close SaveChanges:=wdDoNotSaveChanges
Set wrdDoc = Nothing
wrdApp.Quit
Set wrdApp = Nothing
MsgBox "Complete"
Exit Sub
errHandler:
MsgBox Err.Number & Chr(32) & Err.Description, vbCritical
wrdDoc.Close SaveChanges:=wdDoNotSaveChanges
wrdApp.Quit
Set wrdApp = Nothing
End Sub

Excel VBA - Cross Referencing Bookmark/Form Field to Word

I have very minimal knowledge about VBA but still learning as it goes.
I've been using bookmarks in the word in order to populate data from excel. However, due to the content that some data need to repeat in a document, I tried using Text Form Field/Bookmark and REF Field to duplicate the same data.
The problem came in when once I populated data to the word, the text form field/bookmark disappear which causes REF Field unable to track the data that was referred to, hence, the "Error! Reference source not found."
In conclusion, what I'm trying to do is to populate data from excel to a locked word document and at the same time to retain Text Field Form/Bookmark in order to let REF field to track and duplicate the same data.
Is there any way to retain the Text Field Form/Bookmark placeholder after data is populated to the word? Here's my code that I am unable to solve in excel VBA.
Appreciate your help in advance!
Private Sub CommandButton1_Click()
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
Dim objWord As Object
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
objWord.Documents.Open "C:\Users\" & Environ("username") & "\Desktop\XXX\XXX"
objWord.ActiveDocument.Unprotect Password:="xxx"
With objWord.ActiveDocument
Dim objBMRange As Range
Set objBMRange = .Bookmarks("pr1").Range.Text = ws.Range("C28").Value
objBMRange.Text = pr1
.Bookmarks.Add "pr1", BMRange
.Fields.Update
objWord.ActiveDocument.Protect Password:="xxx", NoReset:=False, Type:=wdAllowOnlyFormFields
End With
Set objWord = Nothing
End Sub
You were almost there. Very near, but you didn't get the Range object sorted out. Please try this code (only partially tested).
Private Sub CommandButton1_Click()
Dim Ws As Worksheet
Dim objWord As Object
Dim Mark As String
Dim Txt As String
Dim BmkStart As Long
Mark = "pr1"
Set Ws = ThisWorkbook.Sheets("Sheet1")
Txt = Ws.Range("C28").Value
Set objWord = CreateObject("Word.Application")
With objWord
.Visible = True
.Documents.Open "C:\Users\" & Environ("username") & "\Desktop\XXX\XXX"
With .ActiveDocument
.Unprotect Password:="xxx"
If .Bookmarks.Exists(Mark) Then
With .Bookmarks(Mark).Range
BmkStart = .Start
.Text = Txt
End With
.Bookmarks.Add Mark, .Range(BmkStart, BmkStart + Len(Txt))
End If
.Fields.Update
.Protect Password:="xxx", NoReset:=False, Type:=wdAllowOnlyFormFields
End With
End With
Set objWord = Nothing
End Sub
One point is that the Bookmark defines a Word.Range (different from an Excel.Range which you get when you specify no application while working in Excel). The other, that Bookmark defines a range but isn't a range itself, not even a Word.Range. Therefore you get or set its text by modifying it's range's Text property.

Loop through Excel rows, key in on value in Word, paste Excel string

I am trying to loop through Excel rows, where column A holds text that I want to find in Word. Column B holds what I want to paste in Word after the end of the paragraph in which the text is found.
When working in Word VBA, the find text is working and moving to the end of the paragraph works. But when I move to Excel VBA, the find method doesn't seem to be doing anything.
Sub UpdateWordDoc1()
Dim mywb As Excel.Worksheet
Set mywb = ActiveWorkbook.ActiveSheet
Dim wdDoc As Object, wdApp As Object
Dim questiontext As String
Dim oSearchRange
On Error Resume Next
Set wdDoc = CreateObject("C:\mydoc.docx")
Set wdApp = wdDoc.Application
Set oSearchRange = wdDoc.Content
With mywb
For i = 2 To .Range("A6000").End(xlUp).Row
questiontext = .Range("A" & i).Value
.Range("B" & i).Copy
Set blabla = oSearchRange.Find.Execute.Text = questiontext
blabla.Select
Selection.movedown unit:=wdparagraph
Selection.moveleft unit:=wdcharacter
Selection.PasteAndFormat (wdFormatOriginalFormatting)
Next i
End With
'wdDoc.Close savechanges:=True
Set wdDoc = Nothing
Set wdApp = Nothing
End Sub
I think this code does what you're after. I made a number of small changes to the code in the original post, some important, some not so much. Hopefully the comments help explain why I did what I did:
Sub UpdateWordDoc1()
' REQUIRES A REFERENCE TO:
' Microsoft Word ##.# Object Library
Dim myws As Excel.Worksheet ' Changed wb to ws to better abbreviate worksheet
Dim wdDoc As Word.Document ' No longer a generic object
Dim wdApp As Word.Application ' No longer a generic object
Dim questiontext As String
Dim oSearchRange As Word.Range ' Word range is what will be searched
Dim i As Long ' Loop through rows by count (Long)
Set myws = ActiveWorkbook.ActiveSheet
' On Error Resume Next ' Can't find bugs if they're supressed!!!
Set wdApp = CreateObject("Word.Application") ' Create app before opening doc
' Need to explore what happens
' if Word is already running
wdApp.Visible = True ' Make it visible so we can watch it work
Set wdDoc = wdApp.Documents.Open("C:\mydoc.docx") ' Open the doc
With myws
For i = 2 To .Range("A6000").End(xlUp).Row
' Word's Find function is tricky to program, because
' when Find succeeds, the range is moved! (Find has many
' other odd behaviors). Assuming you want to search the entire doc
' for each search term, we reset the range every time through the
' loop.
Set oSearchRange = wdDoc.Content
questiontext = .Range("A" & i).Value
.Range("B" & i).Copy
' Set blabla = oSearchRange.Find.Execute.Text = questiontext
With oSearchRange.Find
' Note that Word's Find settings are "sticky". For example, if
' you were previously searching for (say) italic text before
' running this Sub, Word may still search for italic, and your
' search could fail. To kill such bugs, explicitly set all of
' Word's Find parameters, not just .Text
.Text = questiontext ' This is what you're searching for
If .Execute Then ' Found it.
' NOTE: This is only gonna make a change
' at the first occurence of questiontext
' When find is successful, oSearchRange will move
' to the found text. But not the selection, so do Select.
oSearchRange.Select
' Now move to where the new text is to be pasted
wdDoc.ActiveWindow.Selection.movedown unit:=wdparagraph
wdDoc.ActiveWindow.Selection.moveleft unit:=wdcharacter
' While debugging, the next statement through me out of single
' step mode (don't know why) but execution continued
' and the remaining words in my list we're found and text
' pasted in as expected.
wdDoc.ActiveWindow.Selection.PasteAndFormat (wdFormatOriginalFormatting)
End If
End With
Next i
End With
' Clean up and close down
wdDoc.Close savechanges:=True
Set oSearchRange = Nothing
Set wdDoc = Nothing
wdApp.Quit
Set wdApp = Nothing
Set myws = Nothing
End Sub
Hope that helps

Resources