Make New Documents from the XL Word List

[dj44]

Hi Folks,

hope all are doing good:)

I am trying to make new documents by extracting paragraphs that have a specific keyword.

In a spreadsheet Column A - is a List of words found in my document

Example

Column A - Find Word
Jaguar
Ferrari
Ford

So the idea is it will go through the document and find all the paragraphs that start with for example Jaguar and then put them in a new document.


I lost the link to the original unfortunately, and then I tried to fix it even more, and I'm not sure what I did.
I have put it together the best i can - it ran but no document was made.





Sub MakeNewFiles()


Dim xlApp As Object
Dim xlWbk As Object
Dim oWorksheet As Object
Dim blnStart As Boolean
Dim i As Long
Dim iLastRows As Long

Dim StrFnd As Range
Dim RngSrc As Range
Dim RngTgt As Range
Dim DocSrc As Document
Dim DocTgt As Document


On Error Resume Next
Set xlApp = GetObject(Class:="Excel.Application")
If xlApp Is Nothing Then
Set xlApp = CreateObject(Class:="Excel.Application")
If xlApp Is Nothing Then
MsgBox "Failed to start Excel", vbExclamation
Exit Sub
End If
blnStart = True
End If


Set DocSrc = ActiveDocument


Set xlWbk = xlApp.Workbooks.Open(FileName:="C:\Users\DJ\Desktop\WordList.xlsx")
Set oWorksheet = xlWbk.Worksheets("Words")
iLastRows = xlWsh.Range("A" & xlWsh.Rows.Count).End(-4162).Row ' -4162 = xlUp
For i = 2 To iLastRows


Set DocTgt = Documents.Add
With DocSrc.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting


Set StrFnd = xlWsh.Range("A" & i).Value

.Text = StrFnd

.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute
End With


Do While .Find.Found
Set RngSrc = .Paragraphs(1).Range
Set RngTgt = DocTgt.Range.Characters.Last
RngTgt.Collapse wdCollapseStart
RngTgt.FormattedText = RngSrc.FormattedText
.Start = RngSrc.End
.Find.Execute
Loop
End With

DocTgt.SaveAs2 FileName:=DocSrc.Path & "\" & StrFnd & ".docx", _
FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False

DocTgt.Close False

Next i
ExitHandler:
On Error Resume Next
xlWbk.Close SaveChanges:=False
If blnStart Then
xlApp.Quit
End If
Application.ScreenUpdating = True
Exit Sub
ErrHandler:
MsgBox Err.Description, vbExclamation
Resume ExitHandler

End Sub






I don't know if its an excel problem or a word problem

Can a pro have a look at it for me - thank you

Dj

[gmayor]

It's a Word problem. The obvious issues are that the worksheet is referred to as oWorksheet and xlWsh. You need to change xlWsh to oWorksheet
strFnd is a string variable not a range variable and should be defined as
StrFnd = xlWsh.Range("A" & i)
You have included an error handler, but not used it in your code. Add the error code before Set DocSrc = ActiveDocument

On Error Goto ErrHandler
If you add Option Explicit to the top of your module, it will force you to declare your variables and the worksheet error would have been obvious.

[dj44]

Hi Graham,
thank you for spotting those errors, I added the new changes with option explicit.
It runs and the blank documents pop up but nothing being extracted to it or saved
any ideas what it is now
thank you
dj

[gmaxey]

Declaring StrFnd as Range makes it a Word.Range variable not an Excel range variable.
You don't need it though.



Sub MakeNewFiles()
Dim oDoc As Document
Dim oRng As Word.Range
Dim oApp As Object, oBook As Object, oSheet As Object
Dim bStartExcel As Boolean
Dim lngIndex As Long, lngLastRow As Long
Dim RngSrc As Range
Dim RngTgt As Range
Dim DocTgt As Document

On Error Resume Next
Set oApp = GetObject(Class:="Excel.Application")
If oApp Is Nothing Then
Set oApp = CreateObject(Class:="Excel.Application")
If oApp Is Nothing Then
MsgBox "Failed to start Excel", vbExclamation
Exit Sub
End If
bStartExcel = True
End If
On Error GoTo 0
Set oBook = oApp.Workbooks.Open(FileName:="D:\Data Stores\Book1.xlsx") 'Change to suit your needs.
Set oWorksheet = oBook.Worksheets("Words")
lngLastRow = oWorksheet.Range("A" & oWorksheet.Rows.Count).End(-4162).Row
Set oDoc = ActiveDocument
For lngIndex = 2 To lngLastRow
Set oRng = oDoc.Range
With oRng.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = oWorksheet.Range("A" & lngIndex).Text
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
While .Execute
If DocTgt Is Nothing Then Set DocTgt = Documents.Add
Set RngSrc = oRng.Paragraphs(1).Range
Set RngTgt = DocTgt.Range.Characters.Last
RngTgt.Collapse wdCollapseStart
RngTgt.FormattedText = RngSrc.FormattedText
oRng.Collapse wdCollapseEnd
Wend
End With
If Not DocTgt Is Nothing Then
DocTgt.SaveAs2 FileName:=oDoc.Path & "\" & oWorksheet.Range("A" & lngIndex).Text & ".docx", _
FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
DocTgt.Close False
End If
Set DocTgt = Nothing
Next lngIndex
oBook.Close SaveChanges:=False
If bStartExcel Then oApp.Quit
Application.ScreenUpdating = True
lbl_Exit:
Exit Sub
End Sub

[dj44]

Hello Greg,


thanks for fixing this, although i must say i am proud that it was not too much of a dogs dinner as per my usual.:grinhalo:

First the object was missing, then i spent ages fixing that, then the option explicit did not work for some reason.

there was a type mismatch some where and then variables got mixed up

and all the rest of the usual bits
any way all's in a days work.

Thanks Graham I mixed up my variables at the last minute when i was testing something

Thank you Greg for helping again:)

good weekend to all folks
dj

[gmaxey]

You're welcome. Glad to help.