Using Excel Extract Content from Word Doc

C

ChrisOK

Well-known Member
Joined
Mar 26, 2003
Messages
601
Had some code (a sub) that performed this long ago; can't find-- searched every advanced search hit on this site and haven't found anything yet - hoping a guru can help! Used to be able to attach sample of what the source content looks like and how I'm needing it laid into the excel file to try to make this easier; appears this option is gone? - Cross posting so I can attach a helpful file attachment example and needing help rather soon so the more eyes the better:
Using Excel VBA Extract Content from Word Doc
I know there's a ton of brilliant friends of many years here on MrExcel that can probably figure something out without a visual - but the link is available if needed!

*Do not need the code to open any files
(User will already have open 1 Excel file (ExampleExtractor.xlsm) and 1 Word file (LogRuleSourceXX.doc) open before running the SUB.
They will open each Word file one at a time -- and there's a large folder full - so I'm needing a sub like this again to expedite ongoing extractions).

THE 4 BASIC RULES THAT THE SUB SHOULD PERFORM:
1==If excel finds one of these rule words in All Caps [IF,AND,OR,PERFORM,THRU] in the Word doc, then copy the content that sits to the immediate RIGHT of that rule word & paste into Excel column C. (copy until a space occurs I think will work)

2==Then, pick up (copy/paste) the content that sits on the immediate RIGHT of the equals sign into Excel column D
(sometimes that content is in quotes - sometimes it's not - so not using quotes in the definition is probably more accurate (to just say in the code to pick up everything to the right of the equals sign on that same line) - and I'll parse off any extra garbage that I don't need)

3==Need the code to look at the Filename of the Word doc and extract the 12th+13th char position, paste that into Col E of Excel

4==Last, the code should locate the "Output" content which always follows the rule word: [TO], copy/paste into Col F of Excel

That's it!

(I threw those RULE WORDS into Col A as an idea that the code could look to that column when performing it's LOOKUP/INDEX -
but it's probably much better to just hard code them into a line of code and manage them there -- if so, disregard column A)

Forever in debt to you if you can figure out a decent sub to expedite this painful process...
Thanks, Chris
 
Sort by date Sort by votes
Try:
Code: 
Sub GetWordDocumentData()
'Note: this code requires a reference to the Word object model to be set via Tools|References in the VBA editor.
Application.ScreenUpdating = False
Dim wdApp As New Word.Application, wdDoc As Word.Document
Dim strFolder As String, strFile As String
Dim StrCode As String, StrIn As String, StrTmp As String, StrOut As String
Dim WkSht As Worksheet, i As Long, j As Long, r As Long
strFolder = GetFolder
If strFolder = "" Then Exit Sub
Set WkSht = ActiveSheet
r = WkSht.Cells(WkSht.Rows.Count, 1).End(xlUp).Row
strFile = Dir(strFolder & "\*.docx", vbNormal)
While strFile <> ""
  Set wdDoc = wdApp.Documents.Open(Filename:=strFolder & "\" & strFile, ReadOnly:=True, AddToRecentFiles:=False, Visible:=False)
  With wdDoc
    StrCode = Mid(.Name, 12, 2)
    With .Range
      With .Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = "[A-Z0-9][!a-z]@^13"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchWildcards = True
        .Execute
      End With
      Do While .Find.Found
        StrIn = Split(.Paragraphs(1).Range.Text, vbCr)(0)
        If StrIn = UCase(StrIn) Then
          StrIn = Replace(Replace(Replace(StrIn, vbTab, " "), ")", " "), "(", " ")
          StrIn = Trim(StrIn)
          Do While InStr(StrIn, "  ")
            StrIn = Replace(StrIn, "  ", " ")
          Loop
          For i = 1 To UBound(Split(StrIn, " = "))
            StrTmp = Split(Split(StrIn, " = ")(i - 1), " ")(UBound(Split(Split(StrIn, " = ")(i - 1), " ")))
            StrOut = StrOut & vbCr & StrTmp & vbTab & Split(Split(StrIn, " = ")(i), " ")(0) & vbTab & StrCode
          Next
          If UBound(Split(StrIn, " OR ")) = 1 Then
            If InStr(Split(StrIn, " OR ")(UBound(Split(StrIn, " OR "))), " = ") = 0 Then
              StrOut = StrOut & vbCr & StrTmp & vbTab & Split(StrIn, " OR ")(1) & vbTab & StrCode
            End If
          End If
          If Split(StrIn, " ")(0) = "MOVE" Then
            StrOut = StrOut & vbCr
            StrTmp = Split(StrIn, " ")(UBound(Split(StrIn, " ")))
            StrOut = Replace(StrOut, StrCode & vbCr, StrCode & vbTab & StrTmp & vbCr)
            StrOut = Left(StrOut, Len(StrOut) - 1)
          Else
            For i = 1 To UBound(Split(StrIn, " TO "))
              StrTmp = Split(Split(StrIn, " TO ")(i - 1), " ")(UBound(Split(Split(StrIn, " TO ")(i - 1), " ")))
              StrOut = StrOut & vbCr & StrTmp & vbTab & Split(Split(StrIn, " TO ")(i), " ")(0) & vbTab & StrCode
            Next
          End If
          If InStr(StrIn, "NOT-PUBLIC-SALES-CODE") > 0 Then
            StrOut = StrOut & "PUBLIC-SALES-CODE" & vbTab & "NO" & vbTab & StrCode
          ElseIf InStr(StrIn, "PUBLIC-SALES-CODE") > 0 Then
            StrOut = StrOut & vbCr & "PUBLIC-SALES-CODE" & vbTab & "YES" & vbTab & StrCode
          End If
          If InStr(StrIn, "NOT-PUBLIC-TIV-12") > 0 Then
            StrOut = StrOut & vbCr & "PUBLIC-TIV-12" & vbTab & "NO" & vbTab & StrCode
          ElseIf InStr(StrIn, "PUBLIC-TIV-12") > 0 Then
            StrOut = StrOut & vbCr & "PUBLIC-TIV-12" & vbTab & "YES" & vbTab & StrCode
          End If
        End If
        .End = .Paragraphs(1).Range.End
        .Collapse wdCollapseEnd
        .Find.Execute
      Loop
    End With
    .Close SaveChanges:=False
  End With
  StrOut = Replace(Replace(Replace(Replace(StrOut, Chr(39), ""), Chr(96), ""), Chr(145), ""), Chr(146), "")
  For i = 1 To UBound(Split(StrOut, vbCr))
    r = r + 1
    StrTmp = Split(StrOut, vbCr)(i)
    For j = 0 To UBound(Split(StrTmp, vbTab))
      WkSht.Cells(r, j + 3).Value = Split(StrTmp, vbTab)(j)
    Next
  Next
  strFile = Dir()
Wend
wdApp.Quit
Set wdDoc = Nothing: Set wdApp = Nothing: Set WkSht = Nothing
Application.ScreenUpdating = True
End Sub

Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function
Note: It's a bit hard to see how some lines might be required to generate ACH-KEY-VAL or ACH-KEY-IND-VAL-IND for the output when neither of those expressions appear in the data...
 
Upvote 0

Excel Facts

Can Excel fill bagel flavors?
You can teach Excel a new custom list. Type the list in cells, File, Options, Advanced, Edit Custom Lists, Import, OK
Back from holiday break - tried the new code in the "ThisWorkbook" area but it doesn't seem to be generating anything this time?
It prompts me to go navigate to the folder where the small 64kb Word (docx) file resides but once I click it and 'OK', it appears nothing takes place?

Regarding the 2 ACH references.. I'm not sure what you mean? on page 6 of the Word doc, both references are visible.. here's a small clip of that chunk of data (the first occurrences are on line 5 and 9):

Code: 
5.  Add TRANS-IND-CODE ‘AA’ to ZJOT0312:
     
	IF WS-ICC = ‘8’
		IF WS-ERRC = ‘N’ OR ‘P’
			IF DODAAC-FOUND = ‘N’ OR VALID-FUND-CODE = ‘N’
				MOVE ‘01’ TO ACH-KEY-VAL-IND
			ELSE
				IF HOLD-REIMB = ‘A’ OR ‘Y’
					IF PUBLIC-SALES-CODE AND PUBLIC-TIV-12
						MOVE ‘12’ TO ACH-KEY-IND-VAL
					ELSE  
						MOVE ‘02’ TO ACH-KEY-IND-VAL
				ELSE
					MOVE ‘03’ TO ACH-KEY-IND-VAL
		ELSE
			IF DODAAC-FOUND = ‘N’ OR VALID-FUND-CODE = ‘N’
				MOVE ‘04’ TO ACH-KEY-VAL-IND
			ELSE
				IF HOLD-REIMB = ‘A’ OR ‘Y’
					IF PUBLIC-SALES-CODE
						MOVE ‘15’ TO ACH-KEY-IND-VAL
					ELSE 
						MOVE ‘05’ TO ACH-KEY-IND-VAL
				ELSE
					IF PUBLIC-SALES-CODE
						MOVE ‘16’ TO ACH-KEY-IND-VAL
					ELSE  
						MOVE ‘06’ TO ACH-KEY-IND-VAL
	ELSE
		IF WS-ICC = ‘9’
			IF DODAAC-FOUND = ‘N’ OR VALID-FUND-CODE = ‘N’

If I'm misunderstanding, please elaborate and I'll try to get you whatever you need... Thanks greatly
 
Upvote 0
ChrisOK said:
Back from holiday break - tried the new code in the "ThisWorkbook" area but it doesn't seem to be generating anything this time?
It prompts me to go navigate to the folder where the small 64kb Word (docx) file resides but once I click it and 'OK', it appears nothing takes place?
Click to expand...
The code works fine for me with the sample data you posted.
ChrisOK said:
Regarding the 2 ACH references.. I'm not sure what you mean? on page 6 of the Word doc, both references are visible.
Click to expand...
The only data I have to work with is what you've posted. The data I were referring to are in post #10 but the output you specified in post #9 contains references to ACH-KEY-VAL and ACH-KEY-IND-VAL-IND, neither of which appear in the data; neither are they present in post #12. What the data do contain is: ACN-KEY-SUF; ACH-KEY-VAL-IND; and ACH-KEY-IND-VAL.
 
Last edited:
Upvote 0
Oh-OK post #10 was a sampling of what the content looks like within the Word doc; (just to show format, etc.)
I didn't paste it all b/c it was an 18 pg docx however, post #9 provides the full list of what the output "should hold" after the code scans through all the Word content.. (all the different things it should be looking for and how it should paste it into the 4 column table.
(the 2nd table in #9 shows what the output actually held - was trying to show the variance and how only 3 columns were generating w/ mixed content)
Sorry for any confusion -

Ok, now for why it might not be working this time around today?
THIS IS LIKE HAVING A BOX w/ a big red bow sitting in from of you and you can't open it --- frustrating b/c I'm dying to see what the new code does!

MAYBE YOU CAN SEE WHERE I MIGHT BE GOING WRONG BELOW:
I opened the Excel tester file, I removed the old code and pasted in the new code within "ThisWorkbook", saved then navigated to a new blank sheet called "sheet3", then hit run -thinking the new output would appear on that blank sheet 3.. but nothing.

I went to the Excel Tools>References to check the check-marked boxes again to make sure the boxes checked the other day were still checked... here's what I have checked (perhaps something should NOT be checked and is preventing the code from running correctly?)
Wait, no --- THAT can't be the case, because the CODE DOES RUN (to the point of giving me the prompt to select a folder) --but after I say "OK" --- it appears this is the point when the code stops..?

Regardless, here's what I have check marked"
[ x ] Visual Basic for Applications
[ x ] Microsoft Excel 16.0 Object Library
[ x ] OLE Automation
[ x ] Microsoft Office 16.0 Object Library
[ x ] Microsoft Word 16.0 Object Library

As a last ditch effort, I removed the code from the ThisWorkbook area, created a new Module1 in that same excel file, pasted and tried to run from there - but I got the same result.. It runs to the point it allows me to select a folder, I select OK to confirm folder selection and then nothing---

Hope something stands out?
 
Upvote 0
Your VBA references look fine.

Are you sure the source folder contains docx files? If it contains doc files you want to process, you should change:
strFile = Dir(strFolder & "\*.docx", vbNormal)
to:
strFile = Dir(strFolder & "\*.doc", vbNormal)
Note that, with theis change, the code will pick up doc, docx & docm files.

To test whether the code is processing anything in the folder, you might insert:
MsgBox strFolder & "" & strFile
before:
Set wdDoc =
If that returns nothing, you might try repairing the Office installation (via Windows Control Panel > Programs > Programs & Features > Microsoft Office (version) > Change > Repair).

If the above message box returns the file path & name, you might then insert:
MsgBox StrIn
before:
If StrIn = UCase(StrIn) Then
or after:
StrIn = Trim(StrIn)
 
Last edited:
Upvote 0
Wow - very strange!!

I verified there's only 1 file and it's properties say it's a .docx file.
Next, I went back to the already open Excel file, moved the code from the new Module I'd created (back over to the "ThisWorksheet" area (THEN) inserted the "Set wdDoc =" where you advised...

Re-ran the code, it returned a Msgbox indicating the full file path and confirmed it as a .docx file.
I clicked OK to continue and got the twirling circle as if it was finally running the code!
When it stopped, I navigated to the blank "Sheet3" and BAM! RESULTS were now there!!

Crazy huh?
It's crazy that adding that one line of code -- got it going!?

NEXT, I went back into the code (left this in place):
insert:
MsgBox strFolder & "" & strFile
before:
Set wdDoc =

AND ADDED what you advised to do 2nd by inserting this here:
MsgBox StrIn
before:
If StrIn = UCase(StrIn) Then

Saved, created a new "Sheet4" (thinking maybe it would generate content on that new empty tab) - hit RUN - but the code only ran up to the point of selecting a folder again - then produced nothing in Sheet4.

Sad and dismayed, I moved that line to the alternative position you advised:
insert:
MsgBox StrIn
or after:
StrIn = Trim(StrIn)

Saved, hit RUN - but the code only ran up to the point of selecting a folder again - then produced nothing in Sheet4.

NEXT, hit save, close, closed out Excel completely, reopened the Excel file, reopened the code, hit RUN again and THIS TIME A TOTALLY DIFFERENT OUTCOME!?
It allowed me to pick the folder as usual, THEN started popping up MsgBox after MsgBox with short little bleeps in each:
"2500 DET-SUF"
"IF ACJ TRANS....etc. "
"IF WS-DOC...etc.: "

After having to hit "OK" about 30+ times, it finished and BAM! Sheet4 was now populated with a 4 column list that looks beautiful!
That was a pain, clicking "OK" over and over but the end result is AB-SO-LUTE-LY PERFECT!!

No idea why that sequence of events made it work -- but maybe you do ---- (so that's why I itemized every move I made)

I went back in, removed the "MsgBox StrIn" after "StrIn = Trim(StrIn)", saved, created a Sheet5, saved again, closed out Excel, reopened file, re-ran and it worked perfectly again (without the 30+ clicks) - lol :beerchug:

Maybe I just needed to close out Excel completely after adding the new code and by restarting it - it got everything going..?
OK- :pray: in debt to you --- this is so friggin' awesome -- what can I do? I donation in your behalf perhaps? So excited... love it!
Happy Dance underway... :dance:
Thank you your-awesomeness!
 
Upvote 0
FOLLOW ON FINDINGS:
Now that I'm on cloud 9, I decided to try to use it as you designed it -- threw multiple files into the test folder to see what happens...

THE OUTCOME:
Put 10 docx files out there, ran the code, each file path popped up, clicked OK after each, then all at once it pasted the extracted content...

QUESTION:
Am I to assume, it runs the complete code for the 1st file it comes to... extracts & puts in temp memory, then opens next file, extracts, adds to memory and so on... then after the last files "OK" is clicked it pastes everything it extracted and stored in temp memory????

Asking this because I'm trying to make sense of the results found in the 4 columns...

Remember how its designed to pick up the 2 chars from the Filename?
Well, on my spreadsheet going down- it lists the 1st 40 rows of content extraction with an "A" "Rule Name" code
Next going down, 34 rows with the "AA" code
Next going down, 20 rows with the "A" code again
and the following continues with the list below...

Trying to understand why all the A's are not together (pasted from the 1st file it came to?)
There's multiple chunks of "A"s here and there throughout the full list of 2,256 rows of extracted content.

Here's the complete list of what it took from the 10 files (each file has a diff code within its name):
There's 2,256 total rows...
The 1st 34 are "AA" and goes down with diff chunks:
34 "AA"
20 "A"
34 "AA"
16 "AD"
20 "A"
34 "AA"
16 "AD"
147 "AE"
20 "A"
34 "AA"
16 "AD"
147 "AE"
20 "AF"
20 "A"
34 "AA"
16 "AD"
147 "AE"
20 "AF"
7 "AG"
20 "A"
34 "AA"
16 "AD"
147 "AE"
20 "AF"
7 "AG"
47 "AH"
20"A"
34 "AA"
16 "AD"
147 "AE"
20 "AF"
7 "AG"
47 "AH"
13 "AM"
20 "A"
34 "AA"
16 "AD"
147 "AE"
20 "AF"
7 "AG"
47 "AH"
13 "AM"
84 "AN"
20 "A"
34 "AA"
16 "AD"
147 "AE"
20 "AF"
7 "AG"
47 "AH"
13 "AM"
84 "AN" (nothing in col 4)
8 "AP" (that do have col 4 data)
35 "AP" (nothing in col 4)

Any ideas on why it did what it did?
Maybe it's best to just do one file at a time and not dump several files into a folder at once?
Hey - that's fine w/ me - I'm thrilled with it working one at a time - which was my goal from the start...

But knowing you had the intent to be way more efficient and do batches of files, I wanted to share what I'm seeing occur in case you're somewhat OCD like me and want to mess w/ it - if not, don't worry about it -- I love 1 at a time just as much!
=====================================

I copy/pasted the same above list and sorted it to look for patterns and here's what I see:

13 "AM"
13 "AM"
13 "AM"
147 "AE"
147 "AE"
147 "AE"
147 "AE"
147 "AE"
147 "AE"
147 "AE"
16 "AD"
16 "AD"
16 "AD"
16 "AD"
16 "AD"
16 "AD"
16 "AD"
16 "AD"
20 "A"
20 "A"
20 "A"
20 "A"
20 "A"
20 "A"
20 "A"
20 "A"
20 "AF"
20 "AF"
20 "AF"
20 "AF"
20 "AF"
20 "AF"
34 "AA"
34 "AA"
34 "AA"
34 "AA"
34 "AA"
34 "AA"
34 "AA"
34 "AA"
34 "AA"
35 "AP" (nothing in col 4)
47 "AH"
47 "AH"
47 "AH"
47 "AH"
7 "AG"
7 "AG"
7 "AG"
7 "AG"
7 "AG"
8 "AP" (that do have col 4 data)
84 "AN"
84 "AN" (nothing in col 4)
-------------------------------------------------

Another thought, what's the status of each file (patterns/nons):
All files are .docx of course,
All are dated 12/27/16, some w/ the same time stamps, some different
In order of how my window shows them, the Filename codes are:
A
AA
AD
AE
AF
AG
AH
AM
AN
AP
Nothing really stands out to me - that could be causing the odd extract/paste pattern of mixed codes but same counts in most cases...

Oh well, I'll proceed w/ doing each one by itself ---and again, offering great thanks!!
 
Upvote 0
Adding the message boxes in no way affects the code's output. It only provides some (annoying) feedback confirming that things are in fact being processed - and waiting till you dismiss the message box before continuing.

When you select a folder to process all the doc/docx files from that folder will be processed and any output from them will appear in the order in which the files are processed. The code does nothing to intersperse records. If that's happening, there's something wrong with your system - either a rogue addin (for which disabling would be appropriate) or a fault in Office itself (for which a repair is called for).

The macro's output should always span columns C-F and be essentially the same as you depicted in post #9.

As for how the code exports the data, the data are first captured in the string variable StrCode and, when all the data from a given document have been captured, StrOut is parsed and the data written to the worksheet. There is one error in the code that needs to be addressed - StrOut isn't being cleared before each new file is processed, with the result that the same data are being written on each iteration, with the new data appended. This may be the cause of the apparent interspersing of data to which you referred. To remedy that, change:
StrCode = Mid(.Name, 12, 2)
to:
StrCode = Mid(.Name, 12, 2): StrOut = ""
 
Upvote 0
Macropod said:
... There is one error in the code that needs to be addressed - StrOut isn't being cleared before each new file is processed, with the result that the same data are being written on each iteration, with the new data appended.
This may be the cause of the apparent interspersing of data to which you referred. To remedy that, change:
StrCode = Mid(.Name, 12, 2)
to:
StrCode = Mid(.Name, 12, 2): StrOut = ""
Click to expand...

Thank you! I think the above remedy corrected that problem, I re-ran it within my original test file and it is not duplicating content now.
You're so smart!

That said, I copied all the code I had in that orig tester file, pasted it into 'ThisWorkbook' of a nice clean file, saved as another macro-enabled excel file and for some reason the code won't run at all!? (won't even get me to the point of selecting a folder)
I tried moving it to another file and the same result.. but when I return to the orig tester file, it runs fine.

The sub name is highlighted in yellow: Sub GetWordDocumentData()
and this of row 4 is highlighted in blue? wdApp As New Word.Application
Any idea why it keeps highlighting these and saying: "Compile Error User defined type not defined"?
I even tried saving, exiting Excel, reopening, trying again - not sure why I can't move code to a new file?

Code: 
Sub GetWordDocumentData()
'Note: this code requires a reference to the Word object model to be set via Tools|References in the VBA editor.
Application.ScreenUpdating = False
Dim wdApp As New Word.Application, wdDoc As Word.Document
Dim strFolder As String, strFile As String
Dim StrCode As String, StrIn As String, StrTmp As String, StrOut As String
Dim WkSht As Worksheet, i As Long, j As Long, r As Long
strFolder = GetFolder
If strFolder = "" Then Exit Sub
Set WkSht = ActiveSheet
r = WkSht.Cells(WkSht.Rows.Count, 1).End(xlUp).Row
strFile = Dir(strFolder & "\*.docx", vbNormal)
While strFile <> ""
  
  MsgBox strFolder & "" & strFile
  Set wdDoc = wdApp.Documents.Open(Filename:=strFolder & "\" & strFile, ReadOnly:=True, AddToRecentFiles:=False, Visible:=False)
  With wdDoc
    StrCode = Mid(.Name, 12, 2): StrOut = ""
    With .Range
      With .Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = "[A-Z0-9][!a-z]@^13"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchWildcards = True
        .Execute
      End With
      Do While .Find.Found
        StrIn = Split(.Paragraphs(1).Range.Text, vbCr)(0)
        
        

        If StrIn = UCase(StrIn) Then
          StrIn = Replace(Replace(Replace(StrIn, vbTab, " "), ")", " "), "(", " ")
          StrIn = Trim(StrIn)

          
          Do While InStr(StrIn, "  ")
            StrIn = Replace(StrIn, "  ", " ")
          Loop
          For i = 1 To UBound(Split(StrIn, " = "))
          StrTmp = Split(Split(StrIn, " = ")(i - 1), " ")(UBound(Split(Split(StrIn, " = ")(i - 1), " ")))
            StrOut = StrOut & vbCr & StrTmp & vbTab & Split(Split(StrIn, " = ")(i), " ")(0) & vbTab & StrCode
          Next
          If UBound(Split(StrIn, " OR ")) = 1 Then
            If InStr(Split(StrIn, " OR ")(UBound(Split(StrIn, " OR "))), " = ") = 0 Then
              StrOut = StrOut & vbCr & StrTmp & vbTab & Split(StrIn, " OR ")(1) & vbTab & StrCode
            End If
          End If
          If Split(StrIn, " ")(0) = "MOVE" Then
            StrOut = StrOut & vbCr
            StrTmp = Split(StrIn, " ")(UBound(Split(StrIn, " ")))
            StrOut = Replace(StrOut, StrCode & vbCr, StrCode & vbTab & StrTmp & vbCr)
            StrOut = Left(StrOut, Len(StrOut) - 1)
          Else
            For i = 1 To UBound(Split(StrIn, " TO "))
              StrTmp = Split(Split(StrIn, " TO ")(i - 1), " ")(UBound(Split(Split(StrIn, " TO ")(i - 1), " ")))
              StrOut = StrOut & vbCr & StrTmp & vbTab & Split(Split(StrIn, " TO ")(i), " ")(0) & vbTab & StrCode
            Next
          End If
          If InStr(StrIn, "NOT-PUBLIC-SALES-CODE") > 0 Then
            StrOut = StrOut & "PUBLIC-SALES-CODE" & vbTab & "NO" & vbTab & StrCode
          ElseIf InStr(StrIn, "PUBLIC-SALES-CODE") > 0 Then
            StrOut = StrOut & vbCr & "PUBLIC-SALES-CODE" & vbTab & "YES" & vbTab & StrCode
          End If
          If InStr(StrIn, "NOT-PUBLIC-TIV-12") > 0 Then
            StrOut = StrOut & vbCr & "PUBLIC-TIV-12" & vbTab & "NO" & vbTab & StrCode
          ElseIf InStr(StrIn, "PUBLIC-TIV-12") > 0 Then
            StrOut = StrOut & vbCr & "PUBLIC-TIV-12" & vbTab & "YES" & vbTab & StrCode
          End If
        End If
        .End = .Paragraphs(1).Range.End
        .Collapse wdCollapseEnd
        .Find.Execute
      Loop
    End With
    .Close SaveChanges:=False
  End With
  StrOut = Replace(Replace(Replace(Replace(StrOut, Chr(39), ""), Chr(96), ""), Chr(145), ""), Chr(146), "")
  For i = 1 To UBound(Split(StrOut, vbCr))
    r = r + 1
    StrTmp = Split(StrOut, vbCr)(i)
    For j = 0 To UBound(Split(StrTmp, vbTab))
      WkSht.Cells(r, j + 3).Value = Split(StrTmp, vbTab)(j)
    Next
  Next
  strFile = Dir()
Wend
wdApp.Quit
Set wdDoc = Nothing: Set wdApp = Nothing: Set WkSht = Nothing
Application.ScreenUpdating = True
End Sub

Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function
 
Upvote 0
You must log in or register to reply here.

Similar threads

A
  • Question Question
Copying whole word document, into excel + formatting columns and cells
Replies
1
Views
257
Macropod
Macropod
S
  • Question Question
VBA code to update/refresh a mail merge in word
Replies
0
Views
872
StephenBart
S
Jaafar Tribak
  • Question Question
Referencing all Running Instances Of Excel, Word and Access
2 3 4
Replies
32
Views
1K
Jaafar Tribak
Jaafar Tribak
J
  • Question Question
Microsoft Word with Excel linked objects
Replies
0
Views
559
jschrock
J
A
  • Question Question
MS Word macro to find text from Excel list in Word doc, then copy and paste chunks from Word doc to new Word doc
Replies
3
Views
2K
amaneta67
A

Forum statistics

Threads
1,223,803
Messages
6,174,687
Members
452,577
Latest member
Filipzgela

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top