The Power Loon
New Member
- Joined
- Feb 7, 2020
- Messages
- 34
- Office Version
- 365
- Platform
- Windows
I must apologize, as I know this crosses over into word. What I am trying to do is create a Macro that will do the following:
- Open multiple word files (pathways starting at A3). Search for words/numbers containing predefined values (starting at B3). Copy the words/numbers. Paste them back into Excel starting at D3 (preferably into separate columns for each word file, but a single column will do as well).
I started building off of some existing code I have, but stopped as this exceeded my abilities. You'll find what I have so far below. I'm hoping one of you could help me out.
Thank you for your time and consideration of this request.
- Open multiple word files (pathways starting at A3). Search for words/numbers containing predefined values (starting at B3). Copy the words/numbers. Paste them back into Excel starting at D3 (preferably into separate columns for each word file, but a single column will do as well).
I started building off of some existing code I have, but stopped as this exceeded my abilities. You'll find what I have so far below. I'm hoping one of you could help me out.
Thank you for your time and consideration of this request.
VBA Code:
Sub Find ()
Dim ws As Worksheet, msWord As Object, itm As Range
Dim i As Long
Dim rc As Long
Set ws = ActiveSheet
Set msWord = CreateObject("Word.Application")
rc = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
With msWord
For i = 3 To rc
.Visible = True
.Documents.Open ws.Range("A" & i).Value
.Activate
With .ActiveDocument.Content.Find
.ClearFormatting
.Replacement.ClearFormatting
For Each itm In ws.UsedRange.Columns("B").Cells
If Not IsEmpty(itm.Value2) Then
With .Find
.Text = "" 'column B characters to find and return words here
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = True
.Execute
End With
End If
Next
.Copy
End With
.ActiveDocument.Close SaveChanges:=True
Next i
.Quit
End With
Set msWord = Nothing
Set ws = Nothing
Range("D3").Select
ActiveSheet.Paste
End Sub