excel vba open file runtime error 424 - vba

Excel 2010 VBA: I'm trying to loop through files in a folder and only open the files with names that contain a certain string. I've done this before and I know the logic works, but I keep getting the 424 error when I'm opening the target files. I'm pretty sure it has something to do with the links and have tried EVERYTHING to turn off those alerts problematically, but I'm still getting the error
Private Sub CommandButton1_Click()
Dim lSecurity As Long
Dim myPath As Variant
lSecurity = Application.AutomationSecurity
Application.AutomationSecurity = msoAutomationSecurityLow
Application.DisplayAlerts = False
Application.AskToUpdateLinks = False
myPath = "F:\Pathname"
Call Recurse(myPath)
Application.AutomationSecurity = lSecurity
Application.DisplayAlerts = True
Application.AskToUpdateLinks = True
End Sub
Function Recurse(sPath As Variant) As String
Dim FSO As New FileSystemObject
Dim myFolder As Folder
Dim myFile As Variant
Dim file As String
Dim A As Workbook
Dim B As Workbook
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim count As Integer
Set myFolder = FSO.GetFolder(sPath)
Set A = ThisWorkbook
i = 2
For Each myFile In myFolder.Files
If InStr(myFile.Name, "_2015_DOMESTIC_TB") <> 0 Then
Set B = Workbooks.Open(Filename:=myFile)
Call Datadump
B.Close SaveChanges:=False
End If
i = i + 1
Next
End Function
Function Datadump()
A.Cells(i, 1).Value = B.Cells(1, 4).Value
For count = 1 To 59
k = 2
A.Cells(i, k).Value = B.Cells(11 + count, 4).Value
count = count + 1
k = k + 1
Next count
End Function

Seems like your function is trying to open a non Excel file. Change your function to (Untested as posting from phone)
Function Recurse(sPath As Variant) As String
Dim FSO As New FileSystemObject
Dim myFolder As Folder
Dim myFile As Variant
Dim file As String
Dim A As Workbook, B As Workbook
Dim i As Integer, j As Integer, k As Integer, count As Integer
Dim MyAr As Variant
Set myFolder = FSO.GetFolder(sPath)
Set A = ThisWorkbook
i = 2
For Each myFile In myFolder.Files
If InStr(myFile.Name, "_2015_DOMESTIC_TB") <> 0 Then
MyAr = Split(myFile.Name, ".")
If MyAr(UBound(MyAr)) Like "xls*" Then '<~~ Check if it is an Excel file
Set B = Workbooks.Open(Filename:=myFile.Name)
Call Datadump
B.Close SaveChanges:=False
End If
End If
i = i + 1
Next
End Function
This function will check that you are trying to open a valid excel file.
If you still get the error then please tell us which line is giving you the error and what is the value of myFile.Name at the time of error.

Related

VBA for copying multiple columns from different workbooks to be in columns next to each other

I am trying to pull data from a folder containing 300 Workbooks, each named 001, 002 etc.
I am only interested in pulling the data from column G of each file and copying it into a separate folder (each file does not have the same amount if data in row G)
I have been able to copy the data across, but I can't seem to get it to move past column 2 and instead writes over the previous column.
The output needed is:
data from column G workbook"001" pasted into "new sheet" column A
data from column G workbook"002" pasted into "new sheet" column B
and so on
Each file in the folder of 300 only has 1 worksheet each, each labelled: 001,002,...,300
This is the code I already had which results in 2 columns of data where 1 gets replaced by each new sheet instead.
Any help to solve this issue would be greatly appreciated.
Sub Copy()
Dim MyFile As String
Dim Filepath As String
Dim q As Long
Dim ThisCol As Integer
Dim ThisRow As Long
Dim CurS As Worksheet
Dim CurRg As Range
Dim InfCol As Integer
Set CurS = ActiveSheet
ThisRow = ActiveCell.Row
ThisCol = ActiveCell.Column
InfCol = 1
Filepath = "C:..."
MyFile = Dir(Filepath)
Do While Len(MyFile) > 0
If MyFile = "Text to column.xlsm" Then
Exit Sub
End If
Workbooks.Open (Filepath & MyFile)
LastRow = Range("G1").CurrentRegion.Rows.Count
Range("G1", Range("G" & LastRow)).Copy ThisWorkbook.Sheets("Sheet1").Range(CurS.Cells(ThisRow, ThisCol + 1), CurS.Cells(ThisRow, ThisCol + CurS.Cells(ThisRow, InfCol).Value))
ActiveWorkbook.Save
ActiveWorkbook.Close
MyFile = Dir
Loop
End Sub
To properly copy in a new column each time, you need a variable that increments during each loop to offset by one each time. When you use ThisCol + 1 you're always getting the same value because ThisCol is not updated.
Something like this:
Sub Copy()
Dim MyFile As String
Dim Filepath As String
Dim q As Long
Dim ThisCol As Integer
Dim ThisRow As Long
Dim CurS As Worksheet
Dim CurRg As Range
Dim InfCol As Integer
Set CurS = ActiveSheet
ThisRow = ActiveCell.Row
ThisCol = ActiveCell.Column
InfCol = 1
Filepath = ReplacewithyouFilePath
MyFile = Dir(Filepath)
Do While Len(MyFile) > 0
If MyFile = "Text to column.xlsm" Then
Exit Sub
End If
'Let's keep a reference to the workbook
Dim wb As Workbook
Set wb = Workbooks.Open(Filepath & MyFile)
'Let's keep a reference to the first sheet where the data is
Dim ws As Worksheet
Set ws = wb.Sheets(1)
Dim LastRow As Long
LastRow = ws.Range("G1").CurrentRegion.Rows.Count
'We create a variable to increment at each column
Dim Counter As Long
'Let's make the copy operation using the Counter
ws.Range("G1", ws.Range("G" & LastRow)).Copy CurS.Range(CurS.Cells(ThisRow, ThisCol + Counter), CurS.Cells(ThisRow + LastRow - 1, ThisCol + Counter))
'We increment the counter for the next file
Counter = Counter + 1
'We use wb to make sure we are referring to the right workbook
wb.Save
wb.Close
MyFile = Dir
'We free the variables for good measure
Set wb = Nothing
Set ws = Nothing
Loop
End Sub
Import Columns
Sub ImportColumns()
Const FOLDER_PATH As String = "C:\Test"
Const FILE_EXTENSION_PATTERN As String = "*.xls*"
Const SOURCE_WORKSHEET_ID As Variant = 1
Const SOURCE_COLUMN As String = "G"
Const SOURCE_FIRST_ROW As Long = 1
Const DESTINATION_WORKSHEET_NAME As String = "Sheet1"
Const DESTINATION_FIRST_CELL_ADDRESS As String = "A1"
Const DESTINATION_COLUMN_OFFSET As Long = 1
Dim pSep As String: pSep = Application.PathSeparator
Dim FolderPath As String: FolderPath = FOLDER_PATH
If Right(FolderPath, 1) <> pSep Then FolderPath = FolderPath & pSep
Dim DirPattern As String: DirPattern = FolderPath & FILE_EXTENSION_PATTERN
Dim SourceFileName As String: SourceFileName = Dir(DirPattern)
If Len(SourceFileName) = 0 Then
MsgBox "No files found.", vbExclamation
Exit Sub
End If
Dim dwb As Workbook: Set dwb = ThisWorkbook ' workbook containing this code
Dim dws As Worksheet: Set dws = dwb.Worksheets(DESTINATION_WORKSHEET_NAME)
Dim dfCell As Range: Set dfCell = dws.Range(DESTINATION_FIRST_CELL_ADDRESS)
Application.ScreenUpdating = False
Dim swb As Workbook
Dim sws As Worksheet
Dim srg As Range
Dim sfCell As Range
Dim slCell As Range
Do While Len(SourceFileName) > 0
If StrComp(SourceFileName, "Text to column.xlsm", vbTextCompare) _
<> 0 Then ' Why 'Exit Sub'? Is this the destination file?
Set swb = Workbooks.Open(FolderPath & SourceFileName, True, True)
Set sws = swb.Worksheets(SOURCE_WORKSHEET_ID)
Set sfCell = sws.Cells(SOURCE_FIRST_ROW, SOURCE_COLUMN)
Set slCell = sws.Cells(sws.Rows.Count, SOURCE_COLUMN).End(xlUp)
Set srg = sws.Range(sfCell, slCell)
srg.Copy dfCell
' Or, if you only need values without formulas and formats,
' instead, use the more efficient:
'dfCell.Resize(srg.Rows.Count).Value = srg.Value
Set dfCell = dfCell.Offset(, DESTINATION_COLUMN_OFFSET) ' next col.
swb.Close SaveChanges:=False ' we are just reading, no need to save!
'Else ' it's "Text to column.xlsm"; do nothing
End If
SourceFileName = Dir
Loop
Application.ScreenUpdating = True
MsgBox "Columns imported.", vbInformation
End Sub

VBA- Import Multiple CSV to a Sheet, Remove Certain Rows/Columns

I am completely new to VBA, but I have CSV files(same format for all of them), and I want to import them to a single sheet on Excel. I was able to read the CSV file according to this code:
Sub R_AnalysisMerger()
Dim WSA As Worksheet
Dim bookList As Workbook
Dim SelectedFiles() As Variant
Dim NFile As Long
Dim FileName As String
Dim ws As Worksheet, vDB As Variant, rngT As Range
Application.ScreenUpdating = False
'Selects the CSV files as SELECTED FILES
Set ws = ThisWorkbook.Sheets(1)
ws.UsedRange.Clear 'Clears current worksheet
SelectedFiles = Application.GetOpenFilename(filefilter:="Excel Files (*.csv*), *.csv*", MultiSelect:=True) 'Selects csv files
For NFile = LBound(SelectedFiles) To UBound(SelectedFiles)
FileName = SelectedFiles(NFile)
Set bookList = Workbooks.Open(FileName, Format:=2)
Set WSA = bookList.Sheets(1)
With WSA
vDB = .UsedRange
Set rngT = ws.Range("a" & Rows.count).End(xlUp)(2)
If rngT.Row = 2 Then Set rngT = ws.Range("A1")
rngT.Resize(UBound(vDB, 1), UBound(vDB, 2)) = vDB
bookList.Close (0)
End With
Next
Application.ScreenUpdating = True
ws.Range("A1").Select
But I have additional requirements:
Skip the first column.
Skip the first four rows.
Remove a certain String from each word in the fifth row.
Im used to java, and usually I would read each line with a "for" loop and set "if" statements to skip the first row and four columns and remove the string from each string if it was present.
I don't know how to do this with this code. From what I understand it just copies the whole CSV file into the sheet?
This solution is based on reading CSV as textstream. I have tried to include feature that makes possible most all things like selecting columns, Rows and so on.
Sub ImportCSV()
Dim fso As New IWshRuntimeLibrary.FileSystemObject
Dim txtStream As IWshRuntimeLibrary.TextStream
Dim files As IWshRuntimeLibrary.files
Dim file As IWshRuntimeLibrary.file
Dim txtLine As String
Dim lineCount As Integer
Dim lastRow As Integer
Dim lineCol As Variant
Dim rng As Range
Application.ScreenUpdating = False
ThisWorkbook.Sheets(1).usedRange.Delete
Set rng = ThisWorkbook.Sheets(1).usedRange
lastRow = 1
Set files = fso.GetFolder("path\folder").files
For Each file In files
If file.Name Like "*.csv" Then
Set txtStream = file.OpenAsTextStream(ForReading, TristateUseDefault)
txtStream.SkipLine ' skip first line, since it containes headers
lineCount = 1
Do
txtLine = txtStream.ReadLine
If lineCount = 5 Then
txtLine = Replace(txtLine, "stringToReplace", "StringToReplcaeWith") ' replace certain string from words in 5'th row
End If
lineCount = lineCount + 1
lineCol = sliceStr(Split(txtLine, ";"), startIdx:=4) ' slice the array so to skip four first columns
For iCol = 0 To UBound(lineCol) ' write columns to last row
rng(lastRow, iCol + 1).Value = lineCol(iCol)
Next iCol
lastRow = lastRow + 1
'Debug.Print Join(lineCol, ";") ' debug
Loop Until txtStream.AtEndOfStream
End If
Next file
Application.ScreenUpdating = True
End Sub
This is the slicer function
Function sliceStr(arr As Variant, startIdx As Integer, Optional stopIdx As Integer = 0) As String()
If stopIdx = 0 Then
stopIdx = UBound(arr)
End If
Dim tempArrStr() As String
ReDim tempArrStr(stopIdx - startIdx)
Dim counter As Integer
counter = 0
For i = startIdx To stopIdx
tempArrStr(counter) = arr(i)
counter = counter + 1
Next
sliceStr = tempArrStr
End Function
I just did a simple test and the code below seems to work. Give it a go, and feedback.
Sub Demo()
Dim fso As Object 'FileSystemObject
Dim fldStart As Object 'Folder
Dim fld As Object 'Folder
Dim fl As Object 'File
Dim Mask As String
Application.ScreenUpdating = False
Dim newWS As Worksheet
Set newWS = Sheets.Add(before:=Sheets(1))
Set fso = CreateObject("scripting.FileSystemObject") ' late binding
'Set fso = New FileSystemObject 'or use early binding (also replace Object types)
Set fldStart = fso.GetFolder("C:\Users\ryans\OneDrive\Desktop\output\") ' <-- use your FileDialog code here
Mask = "*.csv"
'Debug.Print fldStart.Path & ""
ListFiles fldStart, Mask
For Each fld In fldStart.SubFolders
ListFiles fld, Mask
ListFolders fld, Mask
Next
Dim myWB As Workbook, WB As Workbook
Set myWB = ThisWorkbook
Dim L As Long, t As Long, i As Long
L = myWB.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row
t = 1
For i = 1 To L
Workbooks.OpenText Filename:=myWB.Sheets(1).Cells(i, 1).Value, DataType:=xlDelimited, Tab:=True
Set WB = ActiveWorkbook
lrow = WB.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row
WB.Sheets(1).Range("B4:E" & lrow).Copy newWS.Cells(t, 2)
t = myWB.Sheets(1).Cells(Rows.Count, "B").End(xlUp).Row + 1
WB.Close False
Next
myWB.Sheets(1).Columns(1).Delete
Application.ScreenUpdating = True
End Sub
Sub ListFolders(fldStart As Object, Mask As String)
Dim fld As Object 'Folder
For Each fld In fldStart.SubFolders
'Debug.Print fld.Path & ""
ListFiles fld, Mask
ListFolders fld, Mask
Next
End Sub
Sub ListFiles(fld As Object, Mask As String)
Dim t As Long
Dim fl As Object 'File
For Each fl In fld.Files
If fl.Name Like Mask Then
t = Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row + 1
'Debug.Print fld.Path & "" & fl.Name
If Sheets(1).Cells(1, 1) = "" Then
Sheets(1).Cells(1, 1) = fld.Path & "\" & fl.Name
Else
Sheets(1).Cells(t, 1) = fld.Path & "\" & fl.Name
End If
End If
Next
End Sub

VBA excel to loop though file and get specific data

I am working on a macro that needs to go though xl?? files in a folder and grab specific info from there.
So far this is what I have come up with. But does not seem to be working. Where am I going wrong?
Sub LoopThroughFolder()
Dim MyFile As String, Str As String, MyDir As String, Wb As Workbook
Dim Rws As Long, Rng As Range
Set Wb = ThisWorkbook
'change the address to suite
MyDir = "\ttsnas02\user_mdocs$\tdf8273\Documents\Rob\External supplier timesheet\CSV Supplier Main\Inbox folder\"
MyFile = Dir(MyDir & "*.xl??") 'change file extension
Application.ScreenUpdating = 0
Application.DisplayAlerts = 0
Do While MyFile <> ""
Dim isMyCellEmpty As Boolean
Dim L3T_Supplier_number As String
Dim L3T_Purchase_Order_number As String
Dim Supplier_Hours1 As Integer
Dim Date_for_Supplier_Hours1 As String
Dim GL_code As String
Dim mydata As Workbook
isMyCellEmpty = IsEmpty(Range("L12"))
If isMyCellEmpty = False Then
Worksheets("sheet5").Select
L3T_Supplier_number = Range("J8")
L3T_Purchase_Order_number = Range("J9")
GL_code = Range("L12")
Supplier_Hours1 = Range("I12")
Set mydata = Workbooks.Open("\\ttsnas02\user_mdocs$\tdf8273\Documents\Rob\External supplier timesheet\posting_supplier.xlsx")
Worksheets("CSV_Table (3)").Range("a1").Select
RowCount = Worksheets("CSV_Table (3)").Range("a1").CurrentRegion.Rows.Count
With Worksheets("CSV_Table (3)").Range("a1")
.Offset(RowCount, 0) = L3T_Supplier_number
.Offset(RowCount, 1) = L3T_Purchase_Order_number
.Offset(RowCount, 4) = GL_code
.Offset(RowCount, 4) = Supplier_Hours1
End With
MyFile = Dir()
Loop
End Sub
Indentation is key
Now that i've indented your code properly (using this indenter). You can clearly see you are missing an End If before the Loop statement
End With
MyFile = Dir()
End If
Loop
note: there may be other issues, but you won't even know about them until you fix this one

Find file and insert path into cell

I have a file name of a pdf that I want to search for in a folder on a shared network drive \\Share\Projects. The pdf will be in one of the subfolders under projects. I then want to return the entire file path of the pdf into a cell (eg \\Share\Projects\Subfolder\Another subfolder\thisone.pdf).
I have started the code but can't figure out how to search a file system:
Sub InsertPath()
Dim PONumber As String
PONumber = InputBox("PO Number:", "PO Number")
'search for order
Dim myFolder As Folder
Dim myFile As File
'This bit doesn't work
Set myFolder = "\\Share\Projects"
For Each myFile In myFolder.Files
If myFile.Name = "PO" & PONumber & ".pdf" Then
'I have absolutely no idea how to do this bit
End If
Next
End Sub
Am I on the right track or is my code completely wrong?
get list of subdirs in vba
slighly modified the above post.
Public Arr() As String
Public Counter As Long
Sub LoopThroughFilePaths()
Dim myArr
Dim i As Long
Dim j As Long
Dim MyFile As String
Const strPath As String = "C:\Personal\" ' change it as per your needs
myArr = GetSubFolders(strPath)
Application.ScreenUpdating = False
Range("A1:B1") = Array("text file", "path")
For j = LBound(Arr) To UBound(Arr)
MyFile = Dir(myArr(j) & "\*.pdf")
Do While Len(MyFile) <> 0
i = i + 1
Cells(i, 1) = MyFile
Cells(i, 2) = myArr(j)
MyFile = Dir
Loop
Next j
Application.ScreenUpdating = True
End Sub
Function GetSubFolders(RootPath As String)
Dim fso As Object
Dim fld As Object
Dim sf As Object
Dim myArr
Set fso = CreateObject("Scripting.FileSystemObject")
Set fld = fso.GetFolder(RootPath)
For Each sf In fld.SUBFOLDERS
Counter = Counter + 1
ReDim Preserve Arr(Counter)
Arr(Counter) = sf.Path
myArr = GetSubFolders(sf.Path)
Next
GetSubFolders = Arr
Set sf = Nothing
Set fld = Nothing
Set fso = Nothing
End Function
Well, your folder declaration isn't set against a filesystemobject so it can't find the folder. And because it's a network location, you may need to map a network drive first so that it's a secure link.
So here's an updated version of your code.
EDIT - to OP's conditions.
Dim PONumber As String
Sub InsertPath()
PONumber = InputBox("PO Number:", "PO Number")
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Dim Servershare As String
ServerShare = "S:\"
Dim Directory As Object
Set Directory = fso.GetFolder(ServerShare)
Subfolderstructure Directory
End Sub
Function Subfolderstructure(Directory As Object)
For Each oFldr in Directory.SubFolders
For Each FileName In oFldr.Files
If FileName.Name = "PO" & PONumber & ".pdf" Then
sheets("Sheet1").range("A1").value = ServerShare & "\PO" & PONumber & ".pdf"
Exit For
End If
Next
Dim sbfldrs : Set sbfldrs = ofldr.SubFolders
If isarray(sbfldrs) then
Subfolderstructure ofldr
End if
Next
'Cleanup
Set FileName = Nothing
Set Directory = Nothing
Set fso = Nothing
End Function
I have not tested this code. Try it out and let me know how it works.

Excel VBA Open Workbooks without duplicating it

I have a list of filenames in one of my workbook. I was wondering if anyone knows how to open the file when the name is not in that list. For example, the list contains names for file “ab”, “bc”, “cd” & “de”. File “ac”, “bd” & “eg” are not in the list, and I only want to open that files so there is no duplication. I know I can just remove the duplication, but it’s time consuming to open files that already exist in the list. I’m new with VBA and I did some research about this topic, but found nothing. I really appreciate anyone that can help me. Thank you!
So here is what I came up so far:
Sub Test1()
Dim File As String
Dim wb As Workbook
Dim wbList As Workbook
Dim filesRange As Range
Dim f As Range
Dim fileName As String
Dim Average As Double
Dim StdDev As Double
Dim OpenNum As Double
Dim Min As Double
Dim Max As Double
Dim wbDestination As Workbook
Const wbPath As String = "C:\Users\10 stop.xlsx"
Const pathToFiles As String = "C:\Users\J\"
File = Dir(pathToFiles, vbDirectory)
Set wbList = Workbooks.Open(wbPath)
Set filesRange = wbList.Sheets("18x17 - 10 mil stop").Range("A:A")
Do While Len(File) > 0
Set f = filesRange.Find(What:=f, LookIn:=xlValues, Lookat:=xlWhole)
If f Is Nothing Then
Set wb = Workbooks.Open(pathToFiles & File)
fileName = ActiveWorkbook.Name
Worksheets(1).Select
Average = Range("B15")
Worksheets(1).Select
StdDev = Range("B16")
Worksheets(1).Select
OpenNum = Range("B13")
Worksheets(1).Select
Min = Range("B17")
Worksheets(1).Select
Max = Range("B18")
Set wbDestination = Workbooks.Open("C:\Users\10 stop.xlsx")
Worksheets(ActiveSheet.Name).Select
Worksheets(ActiveSheet.Name).Range("a1").Select
RowCount = Worksheets(ActiveSheet.Name).Range("a1").CurrentRegion.Rows.Count
With Worksheets(ActiveSheet.Name).Range("a1")
.Offset(RowCount, 0) = fileName
.Offset(RowCount, 1) = Average
.Offset(RowCount, 2) = StdDev
.Offset(RowCount, 3) = OpenNum
.Offset(RowCount, 4) = Min
.Offset(RowCount, 5) = Max
End With
End If
File = Dir()
Loop
End Sub
I got Runtime-error '5': Invalid Procedure Call or Argument on
Set f = filesRange.Find(What:=f, LookIn:=xlValues, Lookat:=xlWhole)
For the files that I want to open and read, I would like to use wildcard "-10_.csv"
I tried many different ways, but all of them gave me blank sheets as result.
I used the 'RecursiveDir' previously, but it's slow and open every files over and over again when I try to update my data.
This is so frustrating :(
Please help!
Added sub-folder searching. Compiled but not tested.
Sub Test1()
Dim wb As Workbook
Dim wbList As Workbook
Dim filesRange As Range
Dim f As Range
Dim wbDestination As Workbook
Dim rw As Range
Dim allFiles As New Collection, File, fName
Const wbPath As String = "C:\Users\10 stop.xlsx"
Const pathToFiles As String = "C:\Users\J\"
Set wbList = Workbooks.Open(wbPath)
Set filesRange = wbList.Sheets("18x17 - 10 mil stop").Range("A:A")
GetFiles pathToFiles, "*-10_.csv", True, allFiles
For Each File In allFiles
fName = FileNameOnly(File)
Set f = filesRange.Find(What:=fName, LookIn:=xlValues, Lookat:=xlWhole)
If f Is Nothing Then
Set wb = Workbooks.Open(File)
'***need to specify sheet name below...
Set rw = wbList.Sheets("sheetname").Cells(Rows.Count, 1) _
.End(xlUp).Offset(1, 0).EntireRow
rw.Cells(1).Value = fName 'or `File` if you want the full path
With wb.Sheets(1)
rw.Cells(2).Value = .Range("B15").Value 'avg
rw.Cells(3).Value = .Range("B16").Value 'stdev
rw.Cells(4).Value = .Range("B13").Value 'opennum
rw.Cells(5).Value = .Range("B17").Value 'min
rw.Cells(6).Value = .Range("B18").Value 'max
End With
wb.Close False 'don't save
End If
Next File
End Sub
'given a path, return only the filename
Function FileNameOnly(sPath)
Dim arr
arr = Split(sPath, "\")
FileNameOnly = arr(UBound(arr))
End Function
Sub GetFiles(StartFolder As String, Pattern As String, _
DoSubfolders As Boolean, ByRef colFiles As Collection)
Dim f As String, sf As String, subF As New Collection, s
If Right(StartFolder, 1) <> "\" Then StartFolder = StartFolder & "\"
f = Dir(StartFolder & Pattern)
Do While Len(f) > 0
colFiles.Add StartFolder & f
f = Dir()
Loop
sf = Dir(StartFolder, vbDirectory)
Do While Len(sf) > 0
If sf <> "." And sf <> ".." Then
If (GetAttr(StartFolder & sf) And vbDirectory) <> 0 Then
subF.Add StartFolder & sf
End If
End If
sf = Dir()
Loop
For Each s In subF
GetFiles CStr(s), Pattern, True, colFiles
Next s
End Sub