I have a folder full of word documents I need to transfer to Excel. I need to convert multiple Word documents that basically consist out of one big table into multiple Excel sheets in one workbook.
I found the following code:
Sub Demo()
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, xlSheet As Worksheet
Dim wdApp As Object, wdDoc As Object
strFolder = GetFolder
If strFolder = "" Then Exit Sub
Set wdApp = CreateObject("Word.Application")
strFile = Dir(strFolder & "\*.doc", vbNormal)
While strFile <> ""
Set xlSheet = ThisWorkbook.Sheets.Add
Set wdDoc = wdApp.Documents.Open(strFolder & "\" & strFile)
With wdDoc
.Range.Copy
.Close False
End With
xlSheet.Paste
strFile = Dir()
Wend
Set wdDoc = Nothing: Set xlSheet = 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
It works to a point until it gives me "Run-Time error '1004': Method 'Paste' of object'_Worksheet' failed" and then stops with still a few sheets to process.
Debugging Highlights xlSheet.Paste.
Any idea how to fix this to run through all the word filesand copy them?
Related
I have a code that I found to loop through all of the files in the folder named Loop_AllWordFiles_inFolder and it calls whatever code you put in to execute some kind of action on the word documents in your selected folder. This code will run.
However I run into a problem when I try to have it call upon the code.. I don't know how to make them run together. The code it's calling is called ExtractSubject which is the action I need executed. I found this code online which runs through one file at a time and I'm trying to combine it with the looping files.
I'm new to VBA and I'm not sure how to fix the ExtractSubject code so they can run together. My end goal is to have two columns one with the title of the file and then beside it in the next cell the subject which I will be extracting. Something like this 1
Also I can't open a file without this read-only pop-up2 so if anyone knows how to fix that it would be appreciated but this is not my main concern atm.
Here's the two codes:
Option Explicit
Dim wb As Workbook
Dim path As String
Dim myFile As String
Dim myExtension As String
Dim myFolder As FileDialog
Dim wdApp As Object, wddoc As Object
Sub Loop_AllWordFiles_inFolder()
Set wdApp = CreateObject("Word.Application")
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Retrieve Target Folder Path From User
Set myFolder = Application.FileDialog(msoFileDialogFolderPicker)
With myFolder
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
path = .SelectedItems(1) & "\"
End With
' if the User select "Cancel"
NextCode:
path = path
If path = "" Then GoTo ResetSettings
' Target File Extension
myExtension = "*.doc"
' Target Path with Ending Extention
myFile = Dir(path & myExtension)
' Loop through all doc files in folder
Do While myFile <> ""
Set wddoc = wdApp.Documents.Open(fileName:=path & myFile)
' HERE you call your other routine
Call ExtractSubject
wddoc.Close SaveChanges:=False
myFile = Dir
Loop
Application.DisplayAlerts = PrevDispAlerts
MsgBox "Finished scanning all files in Folder " & path
ResetSettings:
' Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Set wdApp = Nothing
End Sub
Sub ExtractSubject()
Dim cDoc As Word.Document
Dim cRng As Word.Range
Dim i As Long
i = 2
Dim wordapp As Object
Set wordapp = CreateObject("word.Application")
wordapp.Documents.Open "c:\code practice\file1"
wdApp.Visible = True
Set wddoc = ActiveDocument
Set cRng = wddoc.Content
With cRng.Find
.Forward = True
.Text = "SUBJECT:"
.Wrap = wdFindStop
.Execute
'Collapses a range or selection to the starting or ending position
cRng.Collapse Word.WdCollapseDirection.wdCollapseEnd
cRng.MoveEndUntil Cset:="JOB"
Cells(i, 1) = cRng
cRng.Collapse Word.WdCollapseDirection.wdCollapseEnd
.Execute
i = i + 1
End With
wordapp.Quit
Set wordapp = Nothing
End Sub
I think something like this should be close to what you're trying to do. Note you don't want all your variables as Globals - anything which needs to be shared between methods can be passed as an argument or returned as a function result.
Sub Loop_AllWordFiles_inFolder()
Const FILE_EXT As String = ".doc"
Dim wb As Workbook
Dim path As String
Dim myFile As String, theSubject As String
Dim wdApp As Object, wdDoc As Object
'Retrieve Target Folder Path From User
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show = -1 Then path = .SelectedItems(1) & "\"
End With
If Len(path) = 0 Then Exit Sub
'path = "C:\Temp\Test\" 'testing only
myFile = Dir(path & "*" & FILE_EXT) ' Target Path with Ending Extention
If Len(myFile) = 0 Then
MsgBox "No Word files found"
Exit Sub
End If
Set wdApp = CreateObject("Word.Application")
wdApp.Visible = True
Optimize '(don't really need this for this code though...)
Do While myFile <> ""
Set wdDoc = wdApp.Documents.Open(Filename:=path & myFile)
theSubject = ExtractSubject(wdDoc) 'extract subject from wdDoc
wdDoc.Close SaveChanges:=False
If Len(theSubject) > 0 Then 'subject was found?
Name path & myFile As path & theSubject & FILE_EXT 'rename the file
Else
'output any problems
Debug.Print "Subject not found in '" & path & myFile & "'"
End If
myFile = Dir 'next file
Loop
wdApp.Quit 'no need to set to Nothing
Optimize False 'turn off speed enhancements
'Application.DisplayAlerts = PrevDispAlerts '?????
MsgBox "Finished scanning all files in Folder " & path
End Sub
'Return text between "SUBJECT:" and "JOB" in word document `wdDoc`
Function ExtractSubject(wdDoc As Word.document) As String
Dim cRng As Word.Range
Set cRng = wdDoc.content
With cRng.Find
.Forward = True
.Text = "SUBJECT:"
.Wrap = wdFindStop
If .Execute() Then
cRng.Collapse Word.WdCollapseDirection.wdCollapseEnd
cRng.MoveEndUntil Cset:="JOB"
ExtractSubject = Trim(cRng.Text)
End If
End With
End Function
'make changes to application settings to optimize macro speed in excel
Sub Optimize(Optional goFast As Boolean = True)
With Application
.ScreenUpdating = Not goFast
.EnableEvents = Not goFast
.Calculation = IIf(goFast, xlCalculationManual, xlCalculationAutomatic)
End With
End Sub
Try taking a look at this and see if it helps. From what I understand you are just trying to call one function in the middle of another.
From the first sentence of that link: "To call a Sub procedure from another procedure, type the name of the procedure and include values for any required arguments."
I am trying to copy all the text, with formatting intact, from each of multiple Word Documents, and paste the text of each into a new cell in a single Excel Spreadsheet, placing the name of the Word Doc in an adjacent cell.
So the file name of "Document 1" goes in cell A1, and the entire contents of "Document 1" goes in cell A2.
We have several hundred Documents that need to be imported onto pages on our new corporate Intranet, and the migration tool provided only works off data in an Excel workbook.
I've checked out a number of threads, videos, and searches and tried to cobble together a couple of different attempts but neither is working. The first, if it did work, may not handle the File Name copy and it seems to run into issues with selecting the destination cell for the copy.
The second seems to be exactly what I want, but I can;t get the Paste into Excel bit working.
The first runs into an issue when it hits the "Range("LastRow").PasteSpecial xlPasteValues" line, saying the range is invalid (I have defined "LastRow" in the Excel Workbook but it doesn't help) :
Sub Copy_Data_From_Multiple_WordFiles()
Dim FolderName As String
Dim FileName As String
Dim NewWordFile As New Word.Application
Dim NewDoc As New Word.Document
Application.DisplayAlerts = False
'Application.ScreenUpdating = False
FolderName = "C:\Test\"
FileName = Dir(FolderName)
'Loop start
Do While FileName ⋖⋗ ""
Set NewDoc = NewWordFile.documents.Open(FolderName & FileName)
NewDoc.Range(0, NewDoc.Range.End).Copy
Range("LastRow").PasteSpecial xlPasteValues
NewDoc.Close SaveChanges:=wdDoNotSaveChanges
NewWordFile.Quit
FileName = Dir()
Loop
End Sub
NB: LastRow is defined in Excel Name Manager as:=OFFSET(CopyDataFromWord!$A$1,COUNTA(CopyDataFromWord!$A:$A),0,1,1)
I have tried a second set of code I got from a post on here, which should be closer to what I'm seeking, but again, won't quite get there. This one fails with a "Run-Time error '424': Object Required" at the line where it should paste into Excel. It doesn't seem to be recognising the Object "objDoc"?
Sub Excel_Word()
Dim WordApp As Object 'New Word.Application
Dim objDoc As Object ' New Word.Document
Dim Range As Object 'Word.Range
Dim WordDoc As String
Dim sPath As String
Dim i As Long
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = True
sPath = "C:\Users\jdodd\Documents\Cleaned\"
WordDoc = Dir(sPath & "*.docx")
Do While WordDoc <> ""
Set objDoc = WordApp.Documents.Open(sPath & WordDoc)
objDoc.Range.Copy
i = i + 1
ImportPolicyfromWord.Cells(i, 1).Value = objDoc
ImportPolicyfromWord.Cells(i, 2).Value = objDoc.Range.PasteSpecial
WordDoc = Dir()
Loop
WordApp.Quit
'elimina variabili
'Set WordApp = Nothing
'Set objDoc = Nothing
End Sub
Appreciate any advice or help
Try:
Sub GetDocData()
'Note: this code requires a reference to the Word object model.
'See under the VBE's Tools|References.
Application.ScreenUpdating = False
Dim strFolder As String: strFolder = GetFolder: If strFolder = "" Then GoTo ErrExit
Dim wdApp As New Word.Application, wdDoc As Word.Document
Dim strFile As String, WkSht As Worksheet, r As Long
Set WkSht = ActiveSheet
'Disable any auto macros in the documents being processed
wdApp.WordBasic.DisableAutoMacros
'Disable any alerts in the documents being processed
wdApp.DisplayAlerts = wdAlertsNone
strFile = Dir(strFolder & "\*.doc", vbNormal)
While strFile <> ""
Set wdDoc = wdApp.Documents.Open(Filename:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
With wdDoc
.ConvertNumbersToText (wdNumberAllNumbers)
With .Range.Find
.ClearFormatting
.Replacement.ClearFormatting
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchWildcards = True
.Text = "[^12^13^l]{1,}"
.Replacement.Text = "¶"
.Execute Replace:=wdReplaceAll
.Text = "[^t]"
.Replacement.Text = " "
.Execute Replace:=wdReplaceAll
End With
r = WkSht.UsedRange.Cells.SpecialCells(xlCellTypeLastCell).Row
If r > 1 Then r = r + 2
WkSht.Range("A" & r).Value = .Name
.Range.Copy
r = r + 1
WkSht.Paste Destination:=WkSht.Range("A" & r)
.Close SaveChanges:=False
End With
strFile = Dir()
Wend
ErrExit:
wdApp.Quit
WkSht.UsedRange.Replace What:="¶", Replacement:=Chr(10), LookAt:=xlPart, SearchOrder:=xlByRows
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
Simply select the folder to process. As coded, the macro places the document name above the contents, which are all pasted into one cell. If you want the document name on the same row, but beside the contents, change:
r = r + 1
WkSht.Paste Destination:=WkSht.Range("A" & r)
to:
WkSht.Paste Destination:=WkSht.Range("B" & r)
I have a VBA macro that open files in a folder, download data from an add-in, save and close.
This runs fine, but after 10 or 15 files, it gets quite slow. I think it is because Excel still keep previously opened files in the memory. I knew this because I saw the already-opened-and-closed files on the left panel as in the photo below. (the photo is to show where the panel is, I know there is only one file opened with the sheets, but you know what I mean).
My question is: is there a line of code that refresh or clear this temporary memory?
Here is my code:
'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim filename As String
Dim path_to_save As String
Dim FldrPicker As FileDialog
Dim w As Long
Dim StartTime As Double
Dim SecondsElapsed As Double
Dim oFile As Object
Dim oFSO As Object
Dim oFolder As Object
Dim oFiles As Object
Application.ScreenUpdating = False
StartTime = Timer
'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
myPath = .SelectedItems(1) & "\"
End With
'In Case of Cancel
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings
'Assign the folder to oFSO
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder(myPath)
Set oFiles = oFolder.Files
If oFiles.Count = 0 Then GoTo ResetSettings
For Each oFile In oFolder.Files
'Set variable equal to opened workbook
myFile = oFile.Name
Set wb = Workbooks.Open(filename:=myPath & myFile)
Set cmd = Application.CommandBars("Cell").Controls("Refresh All")
cmd.Execute
DoEvents
'Ensure Workbook has opened before moving on to next line of code
wb.Close savechanges:=True
'Ensure Workbook has closed before moving on to next line of code
DoEvents
Next 'oFile
SecondsElapsed = Timer - StartTime
MsgBox "This code ran successfully in " & SecondsElapsed
Set oFile = Nothing
Set oFolder = Nothing
Set oFSO = Nothing
ResetSettings:
'Reset Macro Optimization Settings
Application.ScreenUpdating = True
End Sub
What about add:
set cmd = nothing
before
wb.Close savechanges:=True
There is a known issue in Excel with closed Workbooks leaving data in Memory, which can only be cleared by closing and reopening Excel.
The below code uses a late-bound second instance of the Excel application, in an attempt to alleviate this issue; the second instance will be closed and reopened periodically (currently set to every 5 files).
Sub SomeName()
'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim filename As String
Dim path_to_save As String
Dim FldrPicker As FileDialog
Dim w As Long
Dim StartTime As Double
Dim SecondsElapsed As Double
Dim oFile As Object
Dim oFSO As Object
Dim oFolder As Object
Dim oFiles As Object
'NEW CODE
Dim appXL AS Object, counterFiles AS Long
counterFiles = 0
Application.ScreenUpdating = False
StartTime = Timer
'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
myPath = .SelectedItems(1) & "\"
End With
'In Case of Cancel
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings
'Assign the folder to oFSO
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder(myPath)
Set oFiles = oFolder.Files
If oFiles.Count = 0 Then GoTo ResetSettings
For Each oFile In oFolder.Files
'NEW CODE
If appXL Is Nothing Then Set appNewExcel = CreateObject("Excel.Application")
DoEvents
'Set variable equal to opened workbook
myFile = oFile.Name
Set wb = appNewExcel.Workbooks.Open(filename:=myPath & myFile)
'Update / Refresh workbook
wb.RefreshAll
appNewExcel.CalculateFullRebuild
DoEvents
'Ensure Workbook has opened before moving on to next line of code
wb.Save
DoEvents
wb.Close savechanges:=True
'Ensure Workbook has closed before moving on to next line of code
'NEW CODE
Set wb = Nothing
counterFiles = counterFiles+1
If counterFiles mod 5 = 0 Then
appNewExcel.Quit
Set appNewExcel = Nothing
End If
DoEvents
Next 'oFile
SecondsElapsed = Timer - StartTime
MsgBox "This code ran successfully in " & SecondsElapsed
Set oFile = Nothing
Set oFolder = Nothing
Set oFSO = Nothing
ResetSettings:
'Reset Macro Optimization Settings
Application.ScreenUpdating = True
End Sub
As mentioned in title I have a folder with word files and I want to copy from these files all tables to seperate sheets. I have tried to adapt the solutions from the internet but none of them works (or maybe I did not apply them correctly).
The error I encounter is
1004 "Method 'Paste' of object '_Worksheet' failed"
or sometimes it cannot copy/paste due to merged cells.
It shows on line code:
WkSht.Paste Destination:=WkSht.Range("A" & r)
What is strange when I rerun the macro it does go properly trough all files in folder. But I have to kill the word sometimes in task managers due to OLE error
"Microsoft Excel is waiting for another application to complete an OLE action."
choosing File, Options, Advanced, and under General Ignore other applications that use DDE does not help.
Public wdApp As New Word.Application, wdDoc As Word.Document, wdTbl As Word.Table
Public strFolder As String, strFile As String, WkBk As Workbook, WkSht As Worksheet, r As Long
Sub GetTableData()
Application.ScreenUpdating = False
Dim x As Integer
strFolder = GetFolder: If strFolder = "" Then GoTo ErrExit
Set WkBk = ActiveWorkbook
wdApp.WordBasic.DisableAutoMacros
strFile = Dir(strFolder & "\*.doc*", vbNormal)
While strFile <> ""
Set wdDoc = wdApp.Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
Set WkSht = WkBk.Sheets.Add
x = x + 1
WkSht.Name = Mid(strFile, 20, 29) & x
With wdDoc
For Each wdTbl In .Tables
With wdTbl.Range.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "[^13^l]"
.Replacement.Text = "¶"
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchWildcards = True
.Execute Replace:=wdReplaceAll
End With
r = WkSht.Cells(WkSht.Rows.Count, 1).End(xlUp).Row
If r > 1 Then r = r + 2
wdTbl.Range.Copy
WkSht.Paste Destination:=WkSht.Range("A" & r)
Next
WkSht.UsedRange.Replace What:="¶", Replacement:=Chr(10), LookAt:=xlPart, SearchOrder:=xlByRows
.Close SaveChanges:=False
End With
strFile = Dir()
Wend
ErrExit:
wdApp.Quit
Set wdDoc = Nothing: Set wdApp = Nothing: Set WkSht = Nothing: Set WkBk = 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
Function sheet_exists(sheet_to_find As String) As Boolean
Dim work_sheet As Worksheet
sheet_exists = False
For Each work_sheet In ThisWorkbook.Worksheets
If sheet_to_find = work_sheet.Name Then
sheet_exists = True
Exit Function
End If
Next work_sheet
End Function
I'm trying to create a report that analyzes multiple word documents in a folder and analyzes checkboxes in the document to determine if a set of tests passed or failed. I have code that loops through all documents in a folder, but I'm having a hard time determining how to determine if the boxes are checked.
The first checkbox I'm trying to evaluate is tagged "PassCheckBox". I've found several articles with syntax on how to do this, but none seem to work with the way I'm iterating through the word files. My current code give me "Object is Required" when I try to run.
Here is my current code:
Sub ParseTestFiles()
Dim FSO As Object
Dim fPath As String
Dim myFolder, myFile
Dim wdApp As Object
Dim PassValue As Boolean
fPath = ActiveWorkbook.Path
Set FSO = CreateObject("Scripting.FileSystemObject")
Set myFolder = FSO.GetFolder(fPath).Files
For Each myFile In myFolder
If LCase(myFile) Like "*.doc" _
Or LCase(myFile) Like "*.docx" Or LCase(myFile) Like "*.docm" Then
On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If Err.Number <> 0 Then 'Word not yet running
Set wdApp = CreateObject("Word.Application")
End If
On Error GoTo 0
wdApp.Documents.Open CStr(myFile)
wdApp.Visible = True
' Here is where I'm having an issue
PassValue = ActiveDocument.FormFields("PassCheckBox").Checked
Set wdApp = Nothing
End If 'LCase
Next myFile
End Sub
Try to use:
Dim c, wdDoc
Set wdDoc = wdApp.Documents.Open(CStr(myFile))
wdApp.Visible = True
For Each c In wdDoc.ContentControls
If c.Title = "PassCheckBox" Then
PassValue = c.Checked
Exit For
End If
Next
instead
wdApp.Documents.Open CStr(myFile)
wdApp.Visible = True
PassValue = ActiveDocument.FormFields("PassCheckBox").Checked