Splitting an MS Word File using Excel VBA - referencing section ranges - vba

Hopefully a quick one.
I through together a macro for splitting a word file (merged file of letters) into individual pdfs and naming them based on a ref number included in the file.
'Start split
For Each sec In ActiveDocument.Sections
Set rng = sec.Range 'Range of section
SecText = sec.Range.Text 'All text within section
SecTextPosition = InStr(SecText, "Our ref: ") 'Position of "Out ref: " within the section
strCDRS = Mid(SecText, (SecTextPosition + 9), 16) 'Retrieved CDRS reference
If sec.Index < ActiveDocument.Sections.Count Then
rng.MoveEnd wdCharacter, -1 'drop trailing section break
End If
rng.ExportAsFixedFormat strFolder & "\" & Replace(strCDRS, "/", "-") & "-" & strLetterType & ".pdf", wdExportFormatPDF
Set rng = Nothing
Next sec
This works perfectly when embedded in the word file. However, when embedding in the excel file and referencing the document, I get a type mismatch on the:
Set rng = sec.Range 'Range of section
Look at the value of sec.Range, it looks fine, so it appears to be something to do with the rng range object. Am I missing something obvious?
Full draft code as follows:
Sub SplitExport()
Dim sec As Section
Dim rng As Range
Dim strSplitFile As String
Dim strCDRS As String
Dim strLetterType As String
Dim strFolder As String
Dim SecText As String
Dim SecTextPosition As Long
Dim strfldr As FileDialog
Dim strfile As FileDialog
Dim WordFile As Word.Document
'Set word application
Set wordapp = CreateObject("word.Application")
'Pick file to split
Set strfile = Application.FileDialog(msoFileDialogFilePicker)
With strfile
.Title = "Select a file to split"
.AllowMultiSelect = False
.Show
strSplitFile = .SelectedItems(1)
End With
'Check if a file was selected
If strSplitFile = "" Then
MsgBox "Cannot proceed without file selection", vbOKOnly + vbCritical, "Error"
Exit Sub
End If
'Set Letter Type String
strLetterType = InputBox("Please enter letter code...")
If strLetterType = "" Then
MsgBox "Cannot proceed without letter code", vbOKOnly + vbCritical, "Error"
Exit Sub
End If
'Set folder to save PDFs to
Set strfldr = Application.FileDialog(msoFileDialogFolderPicker)
With strfldr
.Title = "Select a folder to save split files"
.AllowMultiSelect = False
.Show
strFolder = .SelectedItems(1)
End With
'Check a folder was selected
If strFolder = "" Then
MsgBox "Cannot proceed without folder selection", vbOKOnly + vbCritical, "Error"
Exit Sub
End If
'Open file to split
Set WordFile = wordapp.Documents.Open(strSplitFile)
WordFile.Activate
'Start split
For Each sec In ActiveDocument.Sections
Set rng = sec.Range 'Range of section
SecText = sec.Range.Text 'All text within section
SecTextPosition = InStr(SecText, "Our ref: ") 'Position of "Out ref: " within the section
strCDRS = Mid(SecText, (SecTextPosition + 9), 16) 'Retrieved reference
If sec.Index < ActiveDocument.Sections.Count Then
rng.MoveEnd wdCharacter, -1 'drop trailing section break
End If
rng.ExportAsFixedFormat strFolder & "\" & Replace(strCDRS, "/", "-") & "-" & strLetterType & ".pdf", wdExportFormatPDF
Set rng = Nothing
Next sec
End Sub

Apologies for wasting anyone's time reading this - I haven't changed the reference from section to Word.section, etc.
I will leave up as a testament to my muppetry.

Related

Loop does not move to next file

I have an issue with the below code. It seems to work fine but apparently it is not able to move to the next file in the directory given; it gets in fact stuck to the first file, and it reopens it, without being able to move on to the next one. Any help super appreciated!
Sub Cash_Line_Check(strTargetPath)
Dim i As Long
Dim sPath As String
Dim sFil As String
Dim FolderPath As String
Dim diaFolder As FileDialog
Dim CurrReturnColumn As Range, TotReturnColumn As Range, VarTotReturnColumn As Range, CashRow As Range
Dim oWbk As Workbook
'Open the file dialog
Set diaFolder = Application.FileDialog(msoFileDialogFolderPicker)
diaFolder.AllowMultiSelect = False
diaFolder.InitialFileName = strTargetPath
diaFolder.Show
FolderPath = diaFolder.SelectedItems(1)
'Without wanting to use the promp, use the below line:
'FolderPath = strTargetFolder
'Cycle through spreadsheets in selected folder
sPath = FolderPath & "\" 'location of files
sFil = Dir(sPath & "*.xls") 'change or add formats
Do While sFil <> "" 'will start LOOP until all files in folder sPath have been looped through
sFilTop20 = Dir(sPath & "TOP20" & "*.xls")
If (Len(sFilTop20) > 0) Then GoTo loopline
Set oWbk = Workbooks.Open(sPath & "\" & sFil) 'opens the file
i = 1 'Selects the sheet to be analysed'
'Perform Check and Record those funds adjusted
With oWbk.Worksheets(i)
Set CurrReturnColumn = .UsedRange.Find("Currency", , xlValues, xlWhole, xlByColumns)
Set TotReturnColumn = .UsedRange.Find("Portfolio", , xlValues, xlWhole, xlByColumns) 'Looks by columns
Set VarTotReturnColumn = .UsedRange.Find("Variation", , xlValues, xlWhole, xlByRows) 'Looks by rows
Set CashRow = .UsedRange.Find("[Cash]", , xlValues, xlWhole, xlByRows)
If .Cells(CashRow.Row, CurrReturnColumn.Column) > 0.1 Or .Cells(CashRow.Row, CurrReturnColumn.Column) < -0.1 Then
.Cells(CashRow.Row, CurrReturnColumn.Column).Value = "-"
End If
If .Cells(CashRow.Row, TotReturnColumn.Column) > 0.1 Or .Cells(CashRow.Row, CurrReturnColumn.Column) < -0.1 Then
.Cells(CashRow.Row, TotReturnColumn.Column).Value = "-"
End If
If .Cells(CashRow.Row, VarTotReturnColumn.Column) > 0.1 Or .Cells(CashRow.Row, CurrReturnColumn.Column) < -0.1 Then
.Cells(CashRow.Row, VarTotReturnColumn.Column).Value = "-"
End If
End With
oWbk.Close True
sFil = Dir(sPath)
loopline:
Loop
End Sub
Different approach to loop through files I use.
Please note you need to check Microsoft Scripting Runtime in Tools>References
Sub find_reports()
Dim fname As String
'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the folder
strPath = ThisWorkbook.Path
fname = ThisWorkbook.Name
Set objFolder = objFSO.GetFolder(strPath)
'If the folder does not contain files, exit the sub
If objFolder.Files.Count = 0 Then
MsgBox "No files in Folder", vbExclamation
Exit Sub
End If
'Loop through each file in the folder
For Each objFile In objFolder.Files
Debug.Print "Folder:" & strPath, "Filename: " & fname
Next objFile
End Sub
Here is a basic way to loop through all Excel files within a given folder:
Sub LoopExcelFiles()
Const xlsPath = "x:\ExcelTests"
Dim fName As String
fName = Dir(xlsPath & "\*.xl*") 'Find the first file
Do While fName <> "" 'keep looping until file isn't found
'do "whatever you gotta do" with each file here:
Debug.Print "Folder:" & xlsPath, "Filename: " & fName
fName = Dir() 'Find the next file (same criteria)
Loop
End Sub
Here is more on the Dir function.

VBA to find word documents and specified words in content and then list in excel

I have multiple word documents in a folder.
What I really want is to list the document names and check whether these docs incude some specified words.
I create two word documents for example to explain.
There are two documents, Doc A and Doc B, in a folder.
I want to list the file name Doc A and Doc B in the excel column A.
After listing the doc name in column A, I want to check whether specified words "classification" and "Statistics" are in the docs.
If these specified words in the document, it will mark in the excel. Please see below picture for the result I want.
I provide the code in the following:
Option Explicit
Private xRow As Long
Sub Get_MAIN_File_Names()
Dim fso As FileSystemObject
Dim xDirect As String
Dim xRootFolder As Folder
Dim DrawingNumb As String
Dim RevNumb As String
Dim rootFolderStr As String
Set fso = New FileSystemObject
xRow = 0
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select Main File"
.Show
'PROCESS ROOT FOLDER
If .SelectedItems.Count <> 0 Then
xDirect = .SelectedItems(1) & "\"
Set xRootFolder = fso.GetFolder(xDirect)
ProcessFolder fso, xRootFolder
End If
End With
End Sub
Private Sub ProcessFolder(fso As FileSystemObject, xFolder As Folder)
Dim xFiles As Files
Dim xFile As File
Dim xSubFolders As Folders
Dim xSubFolder As Folder
Dim xFileName As String
Dim objWordApplication As New Word.Application
Dim objWordDocument As Word.Document
Dim strFile As String
strFile = Dir(xFolder & "*.doc", vbNormal)
While strFile <> ""
With objWordApplication
Set objWordDocument = .Documents.Open(FileName:=xFolder & strFile, AddToRecentFiles:=False, ReadOnly:=True, Visible:=False)
Set xFiles = xFolder.Files
'Adding Column names
Cells(1, "A").Value = "Document Name"
Cells(1, "B").Value = "classification"
Cells(1, "C").Value = "Statistics"
'LOOPS THROUGH EACH FILE NAME IN FOLDER
For Each xFile In xFiles
'EXTRACT INFORMATION FROM FILE NAME, this part may not add
xFileName = xFile.Name
Set Docs = objWordDocument.Content
With Docs.Find
.ClearFormatting
.Text = "classification"
Wrap:=wdFindContinue
End With
With Docs.Find
.ClearFormatting
.Text = "Statistics"
Wrap:=wdFindContinue
End With
'INSERT INFO INTO EXCEL
ActiveCell.Offset(xRow, 0) = xFileName
'Below needs to add.
ActiveCell.Offset(xRow, 1) =
ActiveCell.Offset(xRow, 2) =
'Above needs to add.
xRow = xRow + 1
With objWordDocument
.Close
End With
Next xFile
Set xSubFolders = xFolder.SubFolders
For Each xSubFolder In xSubFolders
ProcessFolder fso, xSubFolder
Next xSubFolder
End Sub
Based on above code, it fails.
I think the problem is With Docs.Find.....; however, I'm not really sure about it.
Moreover, I do not know how to do this part.
'Below needs to add.
ActiveCell.Offset(xRow, 1) =
ActiveCell.Offset(xRow, 2) =
'Above needs to add.
Can any one help me edit the code?
Maybe this code will help you out, it does:
Assume you got a activesheet setup with the three headers there
Loop through .docx files in specified folder
Checks wordrange for specified tekst
Returns true or false and puts found or not found in appropriate cell
Sub LoopWordDocs()
Dim FLDR As String
Dim wDoc As Word.Document
Dim wRNG As Word.Range
Dim LR As Long, COL As Long
Dim WS As String
Dim wAPP As Word.Application
Dim WordWasNotRunning As Boolean
On Error Resume Next
Set wAPP = GetObject(, "Word.Application")
If Err Then
Set wAPP = New Word.Application
WordWasNotRunning = True
End If
On Error GoTo Err_Handler
WS = ThisWorkbook.ActiveSheet.Name
FLDR = "U:\Test\" 'Change directory accordingly
aDoc = Dir(FLDR & "*.docx") 'Change docx to .doc if you need
Do While aDoc <> ""
Set wDoc = Documents.Open(Filename:=FLDR & aDoc)
LR = Sheets(WS).Cells(Rows.Count, "A").End(xlUp).Row + 1
Sheets(WS).Cells(LR, 1) = aDoc
Set wRNG = wDoc.Range
For COL = 2 To 3 'It will loop through B1 and C1 to check if present in text
With wRNG.Find
.Text = Sheets(WS).Cells(1, COL).Text
.MatchCase = False
.MatchWholeWord = True
If wRNG.Find.Execute = True Then
Sheets(WS).Cells(LR, COL) = "V" 'Change V to your liking
Else
Sheets(WS).Cells(LR, COL) = "X" 'Change X to your liking
End If
End With
Next COL
wDoc.Close SaveChanges:=True
aDoc = Dir
Loop
Exit Sub
Err_Handler:
MsgBox "Word caused a problem. " & Err.Description, vbCritical, "Error: " & Err.Number
If WordWasNotRunning Then
wAPP.Quit
End If
End Sub
Note: You'll have to turn on Microsoft Word 14.0 Object Library for this to work

Word will no longer open through excel VBA

Set up a macro to open word documents through excel. It's been working fine, but after copying the code from the test environment into another file it's refusing to open word on every machine I test it on. Every other part of the macro is working fine, but for some reason word will no longer open via macro.
I've attached the code, but any help would be appreciated. It was working earlier today, and because of this i'm having trouble identifying the problem.
Public Function Method2(ByVal rngl As Range, ByVal strSearch As Variant, ByVal sPath As String)
Dim filePath As String
Dim directory As String
Dim fileName As String
Dim myPath As String
Dim myFile As File
Dim FSO As New FileSystemObject
Dim myFolder As Folder
Dim myExtension As String
Dim mySubFolder As Folder
Dim mySubFolder2 As Folder
Dim objWord
Dim objDoc
Dim rngRange
Dim rng1 As Range
Set myFolder = FSO.GetFolder(sPath)
directory = "S:\File Recipes\"
fileName = "Yaroze_Test"
myExtension = "*.docx*"
Set rng1 = Range("A:A").find(strSearch, , xlValues, xlWhole)
If strSearch = "" Then
MsgBox "Please Enter a Product Code!"
Exit Function
End If
If Not rng1 Is Nothing Then
MsgBox "Product Codes Found!"
For Each mySubFolder In myFolder.SubFolders
For Each mySubFolder2 In mySubFolder.SubFolders
For Each myFile In mySubFolder.Files
If InStr(myFile, strSearch) > 0 Then
fileName = Dir(myPath & myExtension)
MsgBox (myFile.Name)
Do While fileName <> ""
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
ChDrive ("S")
ChDir ("S:\File Recipes\")
filePath = myFile.Path
MsgBox directory
objWord.Documents.Open fileName:=filePath
DoEvents
fileName = Dir
Loop
MsgBox "Task Complete!"
End If
Next
For Each myFile In mySubFolder2.Files
If InStr(myFile, strSearch) > 0 Then
fileName = Dir(myPath & myExtension)
' MsgBox (myFile.Name)
Do While fileName <> ""
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
ChDrive ("S")
ChDir ("S:\File Recipes\")
filePath = myFile.Path
' MsgBox directory
objWord.Documents.Open fileName:=filePath
DoEvents
fileName = Dir
Loop
MsgBox "Task Complete!"
End If
Next
Next
Next
Else
MsgBox "Product Codes Not Found!"
End If
' Set rngRange = _
objWord.Range(objWord.Paragraphs(1).Start, objWord.Paragraphs(1).End - 1)
' rngRange.InsertAfter _
"This is now the last sentence in paragraph one."
I've attempted to test the Macro on other computers to see if it was just the copy of word I was using, and I've tested writing new Macros to open word. They worked initially but other macros are now no longer working. I've tried disabling office from references in VBA and testing with that, and I've made sure it's not an issue with instances of word being left open.

VBA macro that reads a Word document and then saves the document based on text in file?

I have about 700 different Word documents that need to be renamed based off a text string. The format of each of the words docs are exactly the same.
In the word doc, there is a string of text that says "Your establishment name 0001 - Reno, NV". Each of the 700 documents contain a different location name.
I need a VBA Macro that can scan each of these word docs to find that text string and then save the document according to whatever the location is. So in this instance, the document should be saved as: 0001 - Reno, NV.docx
My code so far is:
Sub Macro1()
Dim strFilename As String
Dim rngNum As Range
Dim fd As FileDialog
Dim strFolder As String
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
With fd
.Title = "Select the folder that contains the documents."
If .Show = -1 Then
strFolder = .SelectedItems(1) & "\"
Else
MsgBox "You did not select the folder that contains the documents."
Exit Sub
End If
End With
MkDir strFolder & "Processed"
strDoc = Dir$(strFolder & "*.docx")
While strDoc <> ""
Set Doc = Documents.Open(strFolder & strDoc)
With Doc
Selection.HomeKey wdStory
Selection.Find.ClearFormatting
With Selection.Find
Do While .Execute(FindText:="Your establishment name [0-9]{4}", MatchWildcards:=True, Forward:=True, Wrap:=wdFindStop) = True
With Selection
Set rngNum = .Range
strFilename = Right(.Range.Text, 4)
End With
Loop
End With
.SaveAs strFolder & "Processed\" & strFilename
End With
strDoc = Dir$()
Wend
End Sub
This code, at least in theory, has you select the folder in which all of the 700 docs exist and then creates a new folder named "Processed" where all of the new, renamed documents are then placed.
However, when I run the code, I receive this error:
Run time error '5152':
This is not a valid file name.
Try one or more of the following:
*Check the path to make sure it was typed correctly.
*Select a file from the list of files and folders.
I modified your code slightly while I was testing it to make it easier to read, wasn't exactly sure where your errors were coming from but the following code worked for me:
Sub Macro1()
Dim strFolder As String
Dim strDoc As String
Dim wordApp As Word.Application
Dim wordDoc As Word.document
Set wordApp = New Word.Application
wordApp.Visible = True
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
With fd
.Title = "Select the folder that contains the documents."
If .Show = -1 Then
strFolder = .SelectedItems(1) & "\"
Else
MsgBox "You did not select the folder that contains the documents."
Exit Sub
End If
End With
MkDir strFolder & "Processed"
strDoc = Dir$(strFolder & "*.docx")
While strDoc <> ""
Set wordDoc = Word.Documents.Open(strFolder & strDoc)
With wordDoc
.Content.Select
With wordApp.Selection.Find
.Text = "Your establishment name [0-9]{4}"
.MatchWildcards = True
.wrap = wdFindStop
.Execute
End With
.SaveAs strFolder & "Processed\" & Right(wordApp.Selection, 4) & ".docx"
.Close
End With
strDoc = Dir$()
Wend
wordApp.Quit
Set wordApp = Nothing
End Sub
Hope this helps,
TheSilkCode

VBA To find strings in Column A inside a specific folder contains several types of files

i need a code to meet the below requirements
Column A of an excel sheet contains some strings
i will specify a folder to search those strings
in that specified folder, there will be sub folders, and several types of files eg : .txt, .c, .xml etc..
4.i need search the strings one by one in entire folder structure and log all the result like
search strings in column A Howmany occurance in File(s) in B file locations in C
thank you
the below code will search file names entered in column A and stores the location in B
i tried the below:
Option Explicit
Dim fso As New FileSystemObject
Dim i As Long
Dim fld As Folder
Dim c As Range
Sub Find_Path()
Dim nDirs As Long, nFiles As Long, lSize As Currency
Dim sDir As String, sSrchString As String, sItem As String
Dim fldr As FileDialog
111:
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = "D:\Check\" 'ActiveWorkbook.Path & "\"
.Show
If .SelectedItems.Count = 0 Then
MsgBox "Folder to search is not selected"
GoTo 111
Else
sDir = .SelectedItems(1)
End If
End With
MsgBox "You have selected : " & sDir, vbInformation
'Application.Cursor = xlWait
Application.DisplayStatusBar = True
Application.StatusBar = "Please wait..."
For Each c In Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row)
sSrchString = Range("A" & c.Row).Value
lSize = FindFile(sDir, sSrchString, nDirs, nFiles)
If Str(nFiles) = 0 Then
Range("B" & c.Row).Value = "Not Found in the Folder : " & sDir
End If
Next
Application.Cursor = xlDefault
Application.StatusBar = False
End Sub
This will search for files in folder and sub folders. but i need to search string
This is how you can go through a file... Just add it for every file you want to search in
Dim filenum, targetfile, Line
filenum = FreeFile
targetfile = "C:\Mytextfile.txt"
Open targetfile For Input As filenum
Do While Not EOF(filenum)
Input #filenum, Line
'if InStr(1, Line, yourSearchString) then 'check if your string is in this line
Loop
Close filenum