I have been using the getformdata code (below) to collate data from VBA Word Forms, but I would love to know if it's possible to alter the code so I can select a higher folder and it will search all subfolders.
Sub GetFormData()
'Note: this code requires a reference to the Word object model
Application.ScreenUpdating = False
Dim wdApp As New Word.Application
Dim wdDoc As Word.Document
Dim FmFld As Word.FormField
Dim strFolder As String, strFile As String
Dim WkSht As Worksheet, i As Long, j As Long
strFolder = GetFolder
If strFolder = "" Then Exit Sub
Set WkSht = ActiveSheet
i = WkSht.Cells(WkSht.Rows.Count, 1).End(xlUp).Row
strFile = Dir(strFolder & "\*.doc", vbNormal)
While strFile <> ""
i = i + 1
Set wdDoc = wdApp.Documents.Open(Filename:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
With wdDoc
j = 0
For Each FmFld In .FormFields
j = j + 1
WkSht.Cells(i, j) = FmFld.Result
Next
End With
wdDoc.Close SaveChanges:=False
strFile = Dir()
Wend
I have found code that looks at subfolders, but it seems to be a sub in itself and I don't know where in relation to this I could use it. Thanks.
Related
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
I copied this code to get data from a word document form and put it into an excel spreadsheet and it works great except that the dates are coming in mm/dd/yyyy format. I need to it be dd/mm/yyyy format.
I tried adding a date picker to the form but that hasn't helped.
Normally I would put the formatting into the VBA code but I am unsure how to do that in this code. Can it be inserted or can I somehow reformat the date after it comes into the spreadsheet?
The code is in Excel VBA
Sub GetFormData()
'Note: this code requires a reference to the Word object model
Application.ScreenUpdating = False
Dim wdApp As New Word.Application
Dim wdDoc As Word.Document
Dim CCtrl As Word.ContentControl
Dim strFolder As String, strFile As String
Dim WkSht As Worksheet, i As Long, j As Long
strFolder = GetFolder
If strFolder = "" Then Exit Sub
Set WkSht = Sheets("Data")
i = WkSht.Cells(WkSht.Rows.Count, 1).End(xlUp).Row
strFile = Dir(strFolder & "\*.docx", vbNormal)
While strFile <> ""
i = i + 1
Set wdDoc = wdApp.Documents.Open(Filename:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
With wdDoc
j = 0
For Each CCtrl In .ContentControls
j = j + 1
WkSht.Cells(i, j) = CCtrl.Range.Text
Next
End With
wdDoc.Close SaveChanges:=False
strFile = Dir()
Wend
wdApp.Quit
Set wdDoc = Nothing: Set wdApp = Nothing: Set WkSht = Nothing
Application.ScreenUpdating = True
You may want to replace
WkSht.Cells(i, j) = CCtrl.Range.Text
by
WkSht.Cells(i, j).FormulaLocal = CCtrl.Range.Text
I was working with a vba and I'm trying to open all excel files in a folder (about 8-10) based on cell values. I was wondering if this is the right approach to opening it, it keeps giving me syntax error where I wrote the directory. and when I rewrote that section, the vba only shot out the msgbox which meant it had to have looped and did something right? but didn't open any files. Any information will help. Thank you guys so much for taking the time to help me in any way.
Sub OpenFiles()
Dim search As Worksheet
Dim customer As Range
Dim customerfolder As Range
Dim QualityHUB As Workbook
'setting variable references
Set QualityHUB = ThisWorkbook
Set search = Worksheets("Search")
Set customer = Worksheets("Search").Range("$D$1")
Set customerfolder = Worksheets("Search").Range("$D$3")
With QualityHUB
If IsEmpty((customer)) And IsEmpty((customerfolder)) Then
MsgBox "Please Fill out Customer Information and search again"
Exit Sub
End If
End With
With QualityHUB
Dim MyFolder As String
Dim MyFile As String
Dim Directory As String
Directory = "O:\LAYOUT DATA\" & customer & "\" & customerfolder"
MyFile = Dir(Directory & "*.xlsx")
Do While MyFile <> ""
Workbooks.Open Filename:=MyFile
MyFile = Dir()
Loop
MsgBox "Files Open for " + customerfolder + " complete"
End With
End Sub
This worked for me perfectly
Sub OpenFiles()
Dim search As Worksheet
Dim customer As Range
Dim customerfolder As Range
Dim QualityHUB As Workbook
'setting variable references
Set QualityHUB = ThisWorkbook
Set search = Worksheets("Search")
Set customer = Worksheets("Search").Range("$D$1")
Set customerfolder = Worksheets("Search").Range("$D$3")
With QualityHUB
If IsEmpty((customer)) And IsEmpty((customerfolder)) Then
MsgBox "Please Fill out Customer Information and search again"
Exit Sub
End If
End With
With QualityHUB
Dim MyFolder As String
Dim MyFile As String
Dim Directory As String
Directory = "O:\LAYOUT DATA\" & customer & "\" & customerfolder & "\"
MyFile = Dir(Directory & "*.xlsx")
Do While MyFile <> ""
Workbooks.Open Filename:=Directory & MyFile
MyFile = Dir()
Loop
MsgBox "Files Open for " + customerfolder + " complete"
End With
End Sub
one of the issue was, you had to write
Workbooks.Open Filename:=Directory & MyFile
instead of
Workbooks.Open Filename:=MyFile
Corrected some issues with your code and cleaned it up, give this a try. I think the big issue was you had an extra double-quote, and you missing the ending \ in the Directory line:
Sub OpenFiles()
Dim QualityHUB As Workbook
Dim search As Worksheet
Dim customer As String
Dim customerfolder As String
Dim Directory As String
Dim MyFile As String
'setting variable references
Set QualityHUB = ThisWorkbook
Set search = QualityHUB.Worksheets("Search")
customer = search.Range("$D$1").Value
customerfolder = search.Range("$D$3").Value
If Len(Trim(customer)) = 0 Or Len(Trim(customerfolder)) = 0 Then
MsgBox "Please Fill out Customer Information and search again"
Exit Sub
End If
Directory = "O:\LAYOUT DATA\" & customer & "\" & customerfolder & "\" '<--- This requires the ending \
MyFile = Dir(Directory & "*.xlsx")
Do While Len(MyFile) > 0
Workbooks.Open Filename:=Directory & MyFile
MyFile = Dir()
Loop
MsgBox "Files Open for " + customerfolder + " complete"
End Sub
I found this code online and it will open all the excel files in a folder, you can adapt the code to apply a function to the workbook, once it is open.
Option Explicit
Type FoundFileInfo
sPath As String
sName As String
End Type
Sub find()
Dim iFilesNum As Integer
Dim iCount As Integer
Dim recMyFiles() As FoundFileInfo
Dim blFilesFound As Boolean
blFilesFound = FindFiles("G:\LOCATION OF FOLDER HERE\", _
recMyFiles, iFilesNum, "*.xlsx", True)
End Sub
Function FindFiles(ByVal sPath As String, _
ByRef recFoundFiles() As FoundFileInfo, _
ByRef iFilesFound As Integer, _
Optional ByVal sFileSpec As String = "*.*", _
Optional ByVal blIncludeSubFolders As Boolean = False) As Boolean
Dim iCount As Integer '* Multipurpose counter
Dim sFileName As String '* Found file name
Dim wbResults, file, WS_Count, i, gcell, col, finRow, wbCodeBook As Workbook, lCount, name, looper
Dim WorksheetExists
Set wbCodeBook = ThisWorkbook
'*
'* FileSystem objects
Dim oFileSystem As Object, _
oParentFolder As Object, _
oFolder As Object, _
oFile As Object
Set oFileSystem = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
Set oParentFolder = oFileSystem.GetFolder(sPath)
If oParentFolder Is Nothing Then
FindFiles = False
On Error GoTo 0
Set oParentFolder = Nothing
Set oFileSystem = Nothing
Exit Function
End If
sPath = IIf(Right(sPath, 1) = "\", sPath, sPath & "\")
'*
'* Find files
sFileName = Dir(sPath & sFileSpec, vbNormal)
If sFileName <> "" Then
For Each oFile In oParentFolder.Files
If LCase(oFile.name) Like LCase(sFileSpec) Then
iCount = UBound(recFoundFiles)
iCount = iCount + 1
ReDim Preserve recFoundFiles(1 To iCount)
file = sPath & oFile.name
name = oFile.name
End If
On Error GoTo nextfile:
Set wbResults = Workbooks.Open(Filename:=file, UpdateLinks:=0)
''insert your code here
wbResults.Close SaveChanges:=False
nextfile:
Next oFile
Set oFile = Nothing '* Although it is nothing
End If
If blIncludeSubFolders Then
'*
'* Select next sub-forbers
For Each oFolder In oParentFolder.SubFolders
FindFiles oFolder.path, recFoundFiles, iFilesFound, sFileSpec, blIncludeSubFolders
Next
End If
FindFiles = UBound(recFoundFiles) > 0
iFilesFound = UBound(recFoundFiles)
On Error GoTo 0
'*
'* Clean-up
Set oFolder = Nothing '* Although it is nothing
Set oParentFolder = Nothing
Set oFileSystem = Nothing
End Function
Function SSCGetColumnCodeFromIndex(colIndex As Variant) As String
Dim tstr As String
Dim prefixInt As Integer
Dim suffixInt As Integer
prefixInt = Int(colIndex / 26)
suffixInt = colIndex Mod 26
If prefixInt = 0 Then
tstr = ""
Else
prefixInt = prefixInt - 1
tstr = Chr(65 + prefixInt)
End If
tstr = tstr + Chr(65 + suffixInt)
SSCGetColumnCodeFromIndex = tstr
End Function
Function GetColNum(oSheet As Worksheet, name As String)
Dim Endrow_Col, i
'For loop to get the column number of name
Endrow_Col = oSheet.Range("A1").End(xlToRight).Column
oSheet.Select
oSheet.Range("A1").Select
For i = 0 To Endrow_Col - 1 Step 1
If ActiveCell.Value <> name Then
ActiveCell.Offset(0, 1).Select
ElseIf ActiveCell.Value = name Then
GetColNum = ActiveCell.Column
Exit For
End If
Next i
End Function
Function ShDel(name As String)
End If
End Function
I'm running a VBA script in order to count number of rows in each file in a selected folder and then to display it in an active Workbook.
Option Explicit
Sub CountRows()
Dim wbSource As Workbook, wbDest As Workbook
Dim wsSource As Worksheet, wsDest As Worksheet
Dim strFolder As String, strFile As String
Dim lngNextRow As Long, lngRowCount As Long
Application.ScreenUpdating = False
Set wbDest = ActiveWorkbook
Set wsDest = wbDest.ActiveSheet
strFolder = Dir(Range("C7").Value)
strFile = Dir(strFolder & "*.xlsx")
lngNextRow = 11
Do While Len(strFile) > 0
Set wbSource = Workbooks.Open(Filename:=strFolder & strFile)
Set wsSource = wbSource.Worksheets(1)
lngRowCount = wsSource.UsedRange.Rows.Count
wsDest.Cells(lngNextRow, "F").Value = lngRowCount
wbSource.Close savechanges:=False
lngNextRow = lngNextRow + 1
strFile = Dir
Loop
Application.ScreenUpdating = True
End Sub
Chooing a folder, I would like to use the directory that is inserted in an active WorkBook cell "C7" instead of writing a directory in a script.
I tried to substitute:
strFolder = "C:\Users\user\Desktop\"
with
strFolder = Dir(Range("C7").Value)
but it does not work. Maybe someone has any ideas? Thanks!
This line strFolder = Dir(Range("C7").Value) finds firts file in directory (from C7) and then writes path of this file into variable strFolder (say, C:\temp\somefile.txt).
Next line of your code: strFile = Dir(strFolder & "*.xlsx") takes this path and adds *.xlsx. In result you would get strFile = Dir("C:\temp\somefile.txt*.xlsx") and that's wrong.
So, change this code:
strFolder = Dir(Range("C7").Value)
strFile = Dir(strFolder & "*.xlsx")
to next one:
strFolder = Range("C7").Value
strFile = Dir(strFolder & "*.xlsx")
Btw, I'd recommend you to specify sheet for Range("C7") like this: wsDest.Range("C7")
Try this
dim strPath as string
strPath = CurDir + "NameofFile.xls"
I need to find out the number of rows in each excel sheets under a folder .Google search shows that the below script works..but having very less knowledge on vb ,i could not resolve it.The script containe ''Wscript object.I think this works with out this object as well
The thing is under "c:\temp", i have 100 excel sheets(.xls). Need to find out number of rows in each file. Help needed from vb experts
Dim objFSO, strFolder, objFolder, objFile, objExcel, objSheet, objRange, objRows As Object
Dim strExtension As String
Dim V_FilePath As String = " "
' Specify folder.
strFolder = "c:\\temp" -----
objExcel = CreateObject("Excel.Application")
' Enumerate files in the folder.
objFSO = CreateObject("Scripting.FileSystemObject")
objFolder = objFSO.GetFolder(strFolder)
For Each objFile In objFolder.Files
' Select only Excel spreadsheet file.
strExtension = objFSO.GetExtensionName(objFile.Path)
If (strExtension = "xls") Or (strExtension = "xlsx") Then
' Open each spreadsheet and count the number of rows.
objExcel.Workbooks.Open(objFile.Path)
objSheet = objExcel.ActiveWorkbook.Worksheets(1)
objRange = objSheet.UsedRange
objRows = objRange.Rows
' Display spreadsheet name and the number of rows.
MsgBox(objExcel.ActiveWorkbook + CStr(objRows.Count))
''Wscript.Echo(objFile.Path & " (" & objRows.Count & ")")
' Close the spreadsheet.
objExcel.ActiveWorkbook.Close()
End If
Next
' Clean up.
objExcel.Application.Quit()
Dts.TaskResult = ScriptResults.Success
End Sub
Make sure you're declaring the sub routine at the top with "Sub _()". Also, there are a few things that I believe are syntactically incorrect about this one. Try this instead:
Sub blah()
Dim objFSO, strFolder, objFolder, objFile, objExcel, objSheet, objRange, objRows As Object
Dim strExtension As String
Dim V_FilePath As String
V_FilePath = " "
' Specify folder.
strFolder = "c:\\temp"
objExcel = CreateObject("Excel.Application")
' Enumerate files in the folder.
objFSO = CreateObject("Scripting.FileSystemObject")
objFolder = objFSO.GetFolder(strFolder)
For Each objFile In objFolder.Files
' Select only Excel spreadsheet file.
strExtension = objFSO.GetExtensionName(objFile.Path)
If (strExtension = "xls") Or (strExtension = "xlsx") Then
' Open each spreadsheet and count the number of rows.
objExcel.Workbooks.Open (objFile.Path)
objSheet = objExcel.ActiveWorkbook.Worksheets(1)
objRange = objSheet.UsedRange
objRows = objRange.Rows
' Display spreadsheet name and the number of rows.
MsgBox (objExcel.ActiveWorkbook + CStr(objRows.Count))
''Wscript.Echo(objFile.Path & " (" & objRows.Count & ")")
' Close the spreadsheet.
objExcel.ActiveWorkbook.Close
End If
Next
' Clean up.
objExcel.Application.Quit
Dts.TaskResult = ScriptResults.Success
End Sub
If you're doing this in VBA in an Excel Macro, perhaps this will work a bit better:
Sub LoopThroughFiles()
Dim strFile As String
Dim strPath As String
Dim colFiles As New Collection
Dim i As Integer
Dim rowCount As Integer
strPath = "C:\Users\[windows_username]\Documents\" 'Your path here
strFile = Dir(strPath)
While strFile <> ""
colFiles.Add strFile
strFile = Dir
Wend
'List filenames in Column A of the active sheet
If colFiles.Count > 0 Then
For i = 1 To colFiles.Count
ActiveSheet.Cells(i, 1).Value = colFiles(i)
Workbooks.Open strPath & colFiles(i)
rowCount = ActiveSheet.UsedRange.Rows.Count
Workbooks(colFiles(i)).Close
'Workbooks.Close
'ThisWorkbook.Close
ActiveSheet.Cells(i, 2).Value = rowCount
Next i
End If
End Sub
This would work
MsgBox(objFile.name + CStr(objRows.Count))