I have below VBA code that divided for tWo. First part of the code collect data from file directory and paste it on excel file (file name, path & modified date).
Second part of the code collect all txt file in the folder and marge them to one list in the same sheet.
I tried to improve my code to support more than one folder source and to combine both codes to one ( I joined two different codes to one) but I failed to do it. Any idea how to modified it?
Thanks,
Code:
Sub list()
'adding file name, path & last modify date
Dim FSO As Scripting.FileSystemObject
Dim FileItem As Scripting.File
SourceFolderName = "\\HA04HUCM0002\TestLog\LOT\avi_tests"
Set FSO = New Scripting.FileSystemObject
Set SourceFolder = FSO.GetFolder(SourceFolderName)
Range("c2:e2") = Array("text file", "path", "Date Last Modified")
i = 3
For Each FileItem In SourceFolder.Files
Cells(i, 3) = FileItem.Name
Cells(i, 4) = FileItem
Cells(i, 5) = FileItem.DateLastModified
i = i + 1
Next FileItem
Set FSO = Nothing
'combain txt data into one sheet
Dim xSht As Worksheet
Dim xWb As Workbook
Dim xStrPath As String
Dim xFileDialog As FileDialog
Dim xFile As String
On Error GoTo ErrHandler
Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = False
xFileDialog.Title = "Select a folder [Kutools for Excel]"
If xFileDialog.Show = -1 Then
xStrPath = xFileDialog.SelectedItems(1)
End If
If xStrPath = "" Then Exit Sub
Set xSht = ThisWorkbook.ActiveSheet
If MsgBox("Clear the existing sheet before importing?", vbYesNo, "Kutools for Excel") = vbYes Then xSht.UsedRange.Clear
Application.ScreenUpdating = False
xFile = Dir(xStrPath & "" & "*.txt")
Do While xFile <> ""
Set xWb = Workbooks.Open(xStrPath & "" & xFile)
Columns(1).Insert xlShiftToRight
Columns(1).SpecialCells(xlBlanks).Value = ActiveSheet.Name
ActiveSheet.UsedRange.Copy xSht.Range("A" & Rows.Count).End(xlUp).Offset(1)
xWb.Close False
xFile = Dir
Loop
Application.ScreenUpdating = True
Exit Sub
ErrHandler:
MsgBox "no txt files ", , "Kutools for Excel"
End Sub
To process another folder, simply ask the User if they want to run the code again.
Application.ScreenUpdating = True
If MsgBox("Do you want to process another folder?", vbYesNoCancel, "Kutools for Excel") = vbYes Then
Call list
End If
Related
I found a resource to find specific strings at the following link: https://www.excel-easy.com/vba/examples/read-data-from-text-file.html
How could I apply this to all the .txt files in a folder?
Sub READLINES()
Dim myFile As String, text As String, textline As String, posFood As Integer
'myFile = "C\FOLDER\TEST.txt"
myFile = Application.GetOpenFilename()
Open myFile For Input As #1
Do Until EOF(1)
Line Input #1, textline
text = text & textline
Loop
Close #1
posFood = InStr(text, "BACON")
Range("A1").Value = Mid(text, posFood + 7, 3) 'should return YUM
End Sub
I think your best bet is to import all data from all text files, into one single sheet, and then filter for the strings you want to find, and copy/paste those to another sheet.
Try the script below to import all data from all files.
Sub ImportCSVsWithReference()
'UpdatebyKutoolsforExcel20151214
Dim xSht As Worksheet
Dim xWb As Workbook
Dim xStrPath As String
Dim xFileDialog As FileDialog
Dim xFile As String
On Error GoTo ErrHandler
Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = False
xFileDialog.Title = "Select a folder [Kutools for Excel]"
If xFileDialog.Show = -1 Then
xStrPath = xFileDialog.SelectedItems(1)
End If
If xStrPath = "" Then Exit Sub
Set xSht = ThisWorkbook.ActiveSheet
If MsgBox("Clear the existing sheet before importing?", vbYesNo, "Kutools for Excel") = vbYes Then xSht.UsedRange.Clear
Application.ScreenUpdating = False
xFile = Dir(xStrPath & "\" & "*.txt")
Do While xFile <> ""
Set xWb = Workbooks.Open(xStrPath & "\" & xFile)
Columns(1).Insert xlShiftToRight
Columns(1).SpecialCells(xlBlanks).Value = ActiveSheet.Name
ActiveSheet.UsedRange.Copy xSht.Range("A" & Rows.Count).End(xlUp).Offset(1)
xWb.Close False
xFile = Dir
Loop
Application.ScreenUpdating = True
Exit Sub
ErrHandler:
MsgBox "no files csv", , "Kutools for Excel"
End Sub
Then, run this.
Sub MoveData()
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Dim Rng As Range
Set Rng = Range([A1], Range("A" & Rows.Count).End(xlUp))
On Error Resume Next
With Rng
.AutoFilter , field:=1, Criteria1:="Book1"
.SpecialCells(xlCellTypeVisible).EntireRow.Copy Sheets("Sheet2").Range("A1")
.AutoFilter
End With
Application.EnableEvents = True
End Sub
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 have 27 txt files with the same format and columns, and I want to append all of these in a single excel sheet. I have checked some previous threads here, but I could only find the code below which helped me to import txt fiels into separate sheets. However, I also want to append these separate sheets into a sheet that I want to append all my data.
Sub Test()
'UpdatebyExtendoffice6/7/2016
Dim xWb As Workbook
Dim xToBook As Workbook
Dim xStrPath As String
Dim xFileDialog As FileDialog
Dim xFile As String
Dim xFiles As New Collection
Dim I As Long
Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = False
xFileDialog.Title = "Select a folder [Vendor_data_25DEC]"
If xFileDialog.Show = -1 Then
xStrPath = xFileDialog.SelectedItems(1)
End If
If xStrPath = "" Then Exit Sub
If Right(xStrPath, 1) <> "\" Then xStrPath = xStrPath & "\"
xFile = Dir(xStrPath)
'xFile = Dir(xStrPath & "*.txt") 'this is the original version that you can amend according to file extension
If xFile = "" Then
MsgBox "No files found", vbInformation, "Vendor_data_25DEC"
Exit Sub
End If
Do While xFile <> ""
xFiles.Add xFile, xFile
xFile = Dir()
Loop
Set xToBook = ThisWorkbook
If xFiles.Count > 0 Then
For I = 1 To xFiles.Count
Set xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
xWb.Worksheets(1).Copy after:=xToBook.Sheets(xToBook.Sheets.Count)
On Error Resume Next
ActiveSheet.Name = xWb.Name
On Error GoTo 0
xWb.Close False
Next
End If
End Sub
I am not sure how to do this with VBA in order to combine the data in separate sheets into a single sheet quickly. I know the consolidate feature of excel but it also includes lots of manual steps, so I seek for a faster and automated solution. Any help is much appreciated.
Thanks a lot in advance.
Sub Combiner()
Dim strTextFilePath$, strFolder$
Dim wksTarget As Worksheet
Dim wksSource As Worksheet
Dim x As Long
Set wksTarget = Sheets.Add()
strFolder = "c:\Temp\test\"
strTextFilePath = Dir(strFolder)
While Len(strTextFilePath) > 0
'// "x" variable is just a counter.
'// It's purpose is to track whether the iteration is first or not.
'// If iteration is first (x=1), then we include header (zero offset down),
'// otherwise - we make an offset (1 row offset down).
x = x + 1
Set wksSource = Workbooks.Open(strFolder & strTextFilePath).Sheets(1)
With wksTarget
wksSource.Range("A1").CurrentRegion.Offset(IIf(x = 1, 0, 1)).Copy _
.Cells(.Rows.Count, 1).End(xlUp).Offset(1)
End With
wksSource.Parent.Close False
strTextFilePath = Dir()
Wend
MsgBox "Well done!", vbInformation
End Sub
I have a source folder that contains many xls files. I want to create a master file - collect all information into one database from all files in the given source.
The following code creates 2 columns in master file and enters 2 values from the given source file (one file):
Sub getData()
Dim XL As Excel.Application
Dim WBK As Excel.Workbook
Dim scrFile As String
Dim myPath As String
myPath = ThisWorkbook.path & "\db\" 'The source folder
scrFile = myPath & "1.xlsx" 'Select first file
' Sheet name in the master file is "Sh"
ThisWorkbook.Sheets("Sh").Range("A1").Value = "Column 1"
ThisWorkbook.Sheets("Sh").Range("B1").Value = "Column 2"
Set XL = CreateObject("Excel.Application")
Set WBK = XL.Workbooks.Open(scrFile)
ThisWorkbook.Sheets("Sh").Range("A2").Value = WBK.ActiveSheet.Range("A10").Value
ThisWorkbook.Sheets("Sh").Range("B2").Value = WBK.ActiveSheet.Range("C5").Value
WBK.Close False
Set XL = Nothing
Application.ScreenUpdating = True
End Sub
Now I want to loop through all files and save the values from cells "A10" and "C5" from each file in one database, so the loop should select the next row to save new values.
I have an idea how to loop through all files, but don't know how to switch to the next row:
scrFile = Dir(myPath & "*.xlsx")
Do While scrFile <> ""
Set XL = CreateObject("Excel.Application")
Set WBK = XL.Workbooks.Open(scrFile)
' Here should be the code to save the values of A10 and C5 of the given file
'in the loop in next available row of the master file.
WBK.Close False
Set XL = Nothing
scrFile = Dir
Loop
Any help will be highly appreciated! :)
For simplicity, just use a counter:
scrFile = Dir(myPath & "*.xlsx")
n = 1 ' skip the first row with headers
Do While scrFile <> ""
n = n + 1
Set XL = CreateObject("Excel.Application")
Set WBK = XL.Workbooks.Open(scrFile)
' save the values of A10 and C5 of the given file in the next row
ThisWorkbook.Sheets("Sh").Range("A" & n).Value = WBK.ActiveSheet.Range("A10").Value
ThisWorkbook.Sheets("Sh").Range("B" & n).Value = WBK.ActiveSheet.Range("C5").Value
WBK.Close False
Set XL = Nothing
scrFile = Dir
Loop
msgbox n & " files imported."
BTW, you don't need to start a second Excel instance (CreateObject("Excel.Application")) just to open a second workbook. This will slow down your code a lot. Just open, read and close it. Address your master workbook not by ThisWorkbook but assign a varible to it:
Dim masterWB As Excel.Workbook
set masterWB = ThisWorkbook
...
masterWB.Sheets("Sh").Range("A" & n).Value = WBK.ActiveSheet.Range("A10").Value
You need to recalculate last row in the loop wtih End() function.
Like this for range .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0)
Or to have an integer .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0).Row
Give this a try :
Sub getData()
Application.ScreenUpdating = False
Dim XL As Excel.Application, _
WBK As Excel.Workbook, _
MS As Worksheet, _
scrFile As String, _
myPath As String
'Sheet name in the master file is "Sh"
Set MS = ThisWorkbook.Sheets("Sh")
'The source folder
myPath = ThisWorkbook.Path & "\db\"
MS.Range("A1").Value = "Column 1"
MS.Range("B1").Value = "Column 2"
Set XL = CreateObject("Excel.Application")
scrFile = Dir(myPath & "*.xlsx")
Do While scrFile <> ""
Set WBK = XL.Workbooks.Open(scrFile)
' Here should be the code to save the values of A10 and C5 of the given file
'in the loop in next available row of the master file.
With MS
.Range("A" & .Rows.Count).End(xlUp).Offset(1, 0).Value = WBK.ActiveSheet.Range("A10").Value
.Range("B" & .Rows.Count).End(xlUp).Offset(1, 0).Value = WBK.ActiveSheet.Range("C5").Value
End With
WBK.Close False
scrFile = Dir
Loop
XL.Quit
Set XL = Nothing
Set MS = Nothing
Set WBK = Nothing
Application.ScreenUpdating = True
End Sub
I actually have a code here that will loop through each file and deposit the code into your main file. You are also able to choose the directory of the target folder.
Sub GatherData()
Dim sFolder As String
Application.ScreenUpdating = True
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = Application.DefaultFilePath & "\"
.Title = "Please select a folder..."
.Show
If .SelectedItems.Count > 0 Then
sFolder = .SelectedItems(1) & "\"
Else
Exit Sub
End If
End With
Call Consolidate(sFolder, ThisWorkbook)
End Sub
Private Sub Consolidate(sFolder As String, wbMaster As Workbook)
Dim wbTarget As Workbook
Dim objFso As Object
Dim objFiles As Object
Dim objSubFolder As Object
Dim objSubFolders As Object
Dim objFile As Object
Dim ary(3) As Variant
Dim lRow As Long
'Set Error Handling
On Error GoTo EarlyExit
'Create objects to enumerate files and folders
Set objFso = CreateObject("Scripting.FileSystemObject")
Set objFiles = objFso.GetFolder(strFolder).Files
Set objSubFolders = objFso.GetFolder(strFolder).subFolders
'Loop through each file in the folder
For Each objFile In objFiles
If InStr(1, objFile.Path, ".xls") > 0 Then
Set wbTarget = Workbooks.Open(objFile.Path)
With wbTarget.Worksheets(1)
ary(0) = .Range("B8") 'here you can change the cells you need the data from
ary(1) = .Range("B12")
ary(2) = .Range("B14")
End With
With wbMaster.Worksheets(1)
lRow = .Range("E" & .Rows.Count).End(xlUp).Offset(1, 0).Row 'here you can change the row the data is deposited in
.Range("E" & lRow & ":G" & lRow) = ary
End With
wbTarget.Close savechanges:=False
End If
Next objFile
'Request count of files in subfolders
For Each objSubFolder In objSubFolders
Consolidate objSubFolder.Path, wbMaster
Next objSubFolder
EarlyExit:
'Clean up
On Error Resume Next
Set objFile = Nothing
Set objFiles = Nothing
Set objFso = Nothing
On Error GoTo 0
End Sub
I have worked on this for a while. It's my first Excel VBA macro and I think I am almost there. I just can't seem to find a way to get the information I need from my function or I can't get my function to give me the right information.
I need a macro that will search through a selected folder and its sub-folders for excel workbooks that have specific sheet names contained with in then out put the paths to an excel spreadsheet. Currently my code will either only find the files in a single folder or it will list all the files indiscriminately. Now the code is a bit of a mess because i am unsure of which parts I need and which parts I don't.
Option Explicit
Public ObjFolder As Object
Public objFso As Object
Public objFldLoop As Object
Public lngCounter As Long
Public objFl As Object
Sub ImportSheet()
Dim i As Integer
Dim SourceFolder As String
Dim FileList As Variant
Dim GrabSheet As String
Dim FileType As String
Dim ActWorkBk As String
Dim ImpWorkBk As String
Dim NoImport As Boolean
Dim FileToWriteTo As Variant
Dim xRow As Long
Dim xDirect$, xFname$, InitialFoldr$
Dim MyDir As String, myList()
'Startup folder to begin filedialog search
InitialFoldr$ = "C:"
'Define filetype
FileType = "*.xlsx"
'Define sheetname to copy
GrabSheet = Application.InputBox(prompt:="Please enter name of sheet you wish to find.", Title:="Specify Sheet Name")
'open dialog for user to select a folder to search
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = Application.DefaultFilePath & "\"
.Title = "Please select a folder to list Files from"
.InitialFileName = InitialFoldr$
If .Show = True Then
MyDir = .SelectedItems(1)
End If
End With
On Error Resume Next
myList = SearchFiles(MyDir, "*.xlsx", 0, myList())
If Err = 0 Then
'If user selects folder count the items to search
xDirect$ = MyDir & "\"
xFname$ = Dir(xDirect$, 8)
'Creates list with filenames
FileList = ListFiles(xDirect$ & FileType)
'Imports data
Application.ScreenUpdating = False
ActWorkBk = ActiveWorkbook.Name
NoImport = False
'Clear contents of Active sheet and set active cell to A1
Sheets(1).UsedRange.ClearContents
Sheets(1).Select
Range("A1").Select
For i = 1 To UBound(FileList)
'Opens file
Workbooks.Open (xDirect$ & FileList(i))
ImpWorkBk = ActiveWorkbook.Name
'Checks to see if the specific sheet exists in the workbook
On Error Resume Next
ActiveWorkbook.Sheets(GrabSheet).Select
If Err > 0 Then
NoImport = True
GoTo nxt
End If
Err.Clear
On Error GoTo 0
xFname$ = Dir(xDirect$ & FileList(i))
Do While xFname$ <> ""
ThisWorkbook.Activate
ActiveCell.Offset(xRow) = xDirect$ & xFname$
xRow = xRow + 1
xFname$ = Dir
Loop
'Copies sheet
'ActiveWorkbook.Sheets(GrabSheet).Copy after:=Workbooks(ActWorkBk).Sheets(Workbooks(ActWorkBk).Sheets.Count)
'Renames the imported sheet
On Error Resume Next
ActiveSheet.Name = "Specs with " & GrabSheet
Err.Clear
On Error GoTo 0
nxt:
'Closes importfile
Workbooks(ImpWorkBk).Activate
Application.DisplayAlerts = False
ActiveWorkbook.Saved = True
ActiveWorkbook.Close SaveChanges:=False
Application.DisplayAlerts = True
'Workbooks(ActWorkBk).Activate
Next i
'Error if some sheets were not found
' If NoImport = True Then MsgBox "Some of the files did not contain the sheet " & GrabSheet
Application.ScreenUpdating = True
Else
MsgBox "No file found"
End If
On Error GoTo 0
' End If
'End With
'End Function
End Sub
'WITH SUBFOLDERS - Function that creates an array with all the files in the folder
Private Function SearchFiles(MyDir As String, myFileName As String, n As Long, myList()) As Variant
Dim fso As Object, myFolder As Object, myFile As Object
Set fso = CreateObject("Scripting.FileSystemObject")
For Each myFile In fso.getfolder(MyDir).Files
If (Not myFile.Name Like "~$*") * (myFile.Name <> ThisWorkbook.Name) _
* (myFile.Name Like myFileName) Then
n = n + 1
ReDim Preserve myList(1 To 2, 1 To n)
myList(1, n) = MyDir
myList(2, n) = myFile.Name
End If
Next
For Each myFolder In fso.getfolder(MyDir).subfolders
SearchFiles = SearchFiles(myFolder.Path, myFileName, n, myList)
Next
SearchFiles = IIf(n > 0, myList, "")
End Function
'WITHOUT SUBFOLDERS - Function that creates an array with all the files in the folder
Function ListFiles(Source As String) As Variant
Dim GetFileNames() As Variant
Dim i As Integer
Dim FileName As String
On Error GoTo ErrHndlr
i = 0
FileName = Dir(Source)
If FileName = "" Then GoTo ErrHndlr
'Loops until no more mathing files are found
Do While FileName <> ""
i = i + 1
ReDim Preserve GetFileNames(1 To i)
GetFileNames(i) = FileName
FileName = Dir()
Loop
ListFiles = GetFileNames
On Error GoTo 0
Exit Function
'If error
ErrHndlr:
ListFiles = False
On Error GoTo 0
End Function
This will work right now to give a list using the "ListFiles" Function.
But I can't seem to figure out how to get it to out put a list using the "SearchFiles" Function. Which, ultimately,is what I need it to do.
Please help i feel like I am so close!!!
Ok i figured it out. I was having trouble with the syntax to access my array of arrays. here is the code that ended up doing the trick.
Option Explicit
Public ObjFolder As Object
Public objFso As Object
Public objFldLoop As Object
Public lngCounter As Long
Public objFl As Object
Sub ImportSheet()
Dim i As Integer
Dim GrabSheet As String
Dim ActWorkBk As String
Dim ImpWorkBk As String
Dim NoImport As Boolean
Dim xRow As Long
Dim xFname As String
Dim InitialFoldr As String
Dim MyDir As String, myList()
'Startup folder to begin filedialog search
InitialFoldr = "C:\Users\george.EASYWAY\Desktop\TEST1\"
'Define sheetname to copy
GrabSheet = Application.InputBox(prompt:="Please enter name of sheet you wish to find.", Default:="snagit", Title:="Specify Sheet Name")
'open dialog for user to select a folder to search
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = Application.DefaultFilePath & "\"
.Title = "Please select a folder to list Files from"
.InitialFileName = InitialFoldr
If .Show = True Then
MyDir = .SelectedItems(1)
End If
End With
On Error Resume Next
myList = SearchFiles(MyDir, "*.xlsx", 0, myList())
If Err = 0 Then
'Imports data
Application.ScreenUpdating = False
ActWorkBk = ActiveWorkbook.Name
NoImport = False
'Clear contents of Active sheet and set active cell to A1
Sheets(1).UsedRange.ClearContents
Sheets(1).Select
Range("A1").Select
For i = 1 To UBound(myList, 2)
'Opens file
Workbooks.Open (myList(1, (i)) & "\" & (myList(2, (i))))
ImpWorkBk = ActiveWorkbook.Name
'Checks to see if the specific sheet exists in the workbook
On Error Resume Next
ActiveWorkbook.Sheets(GrabSheet).Select
If Err > 0 Then
NoImport = True
GoTo nxt
End If
Err.Clear
On Error GoTo 0
xFname = Dir(myList(1, (i)) & "\" & (myList(2, (i))))
Do While xFname <> ""
ThisWorkbook.Activate
ActiveCell.Offset(xRow) = (myList(1, (i)) & "\" & (myList(2, (i))))
xRow = xRow + 1
xFname = Dir
Loop
'Renames the imported sheet
On Error Resume Next
ActiveSheet.Name = "Specs with " & GrabSheet
Err.Clear
On Error GoTo 0
nxt:
'Closes importfile
Workbooks(ImpWorkBk).Activate
Application.DisplayAlerts = False
ActiveWorkbook.Saved = True
ActiveWorkbook.Close SaveChanges:=False
Application.DisplayAlerts = True
'Workbooks(ActWorkBk).Activate
Next i
'Error if some sheets were not found
' If NoImport = True Then MsgBox "Some of the files did not contain the sheet " & GrabSheet
Application.ScreenUpdating = True
Else
MsgBox "No file found"
End If
On Error GoTo 0
End Sub
'Function that creates an array with all the files in the folder with subfolders
Function SearchFiles(MyDir As String, myFileName As String, n As Long, myList()) As Variant
Dim fso As Object, myFolder As Object, myFile As Object
Set fso = CreateObject("Scripting.FileSystemObject")
For Each myFile In fso.getfolder(MyDir).Files
If (Not myFile.Name Like "~$*") * (myFile.Name <> ThisWorkbook.Name) _
* (myFile.Name Like myFileName) Then
n = n + 1
ReDim Preserve myList(1 To 2, 1 To n)
myList(1, n) = MyDir
myList(2, n) = myFile.Name
End If
Next
For Each myFolder In fso.getfolder(MyDir).subfolders
SearchFiles = SearchFiles(myFolder.Path, myFileName, n, myList)
Next
SearchFiles = IIf(n > 0, myList, "")
End Function