Excel 2003 VBA Help me complete this Search script

[RompStar]

Hi there,

This is a Sub and a Function. I am relatively new to VBA scripting
for Excel 2003. What I am trying to accomplish is this.

Have this FileSeach look into the path specified and it's sub-
directories, and then refer to the function and try to find all file
names of *.xls type that range within a cetain dates, or a single date
if there is no range in dates. The file names that I am looking for
will have this pattern:

filename_blablablablabla_20071201.xls - always at the end it there
will be a date, using YYYYMMDD.

Since Excel probably havs't a clue about dates in the file names, I
figured I have to somehow teach this to Excel to look in a pre-
determined pattern in the string of the file name and format that as a
date and then maybe I can search a between conditions:

Then the found directory paths would be pasted into the Excel sheet
starting A1 and down.

If anyone knows how to do this in XP using DOS, let me know too :- )



So if I was using this (from the function):

FromDate = "20071201" YYYYMMDD format
ToDate = "20071212"

I would like it to find all the files that are between *20071201.xls -
*20071212.xls, including the Dates them self, if nothing in-between
exists.

I hope I sounds clear, please post back to this forum, so that if is a
success, others can use it as well.

Sub FileFound(strFileName As String)

Dim path As Variant
Dim strDllNms As String

Set fs = Application.FileSearch

With fs
.LookIn = "c:\Kevin\"
.SearchSubFolders = True
.Filename = strFileName & "*.xls"
.FileType = msoFileTypeExcelWorkbooks
If .Execute() > 0 Then
MsgBox "There were " & .FoundFiles.Count & " file(s) found."
Else
MsgBox "There were no files found."
End If

ActiveSheet.Range("A2") =
Application.Transpose(ExtractNewFileName(strFileName))
Cells.EntireColumn.AutoFit

End With

End Sub




Function ExtractNewFileName(strOldFName As String) As String

Dim strFn As String
Dim FromDate, ToDate As String

FromDate = "20071201"
FromDate = Format("YYYYMMDD")
ToDate = "20071212"
ToDate = Format("YYYYMMDD")

strFn = Left(strOldFName, InStrRev(strOldFName, ".", -1,
vbTextCompare) - 1)
strFn = strFn & "_" & Format("YYYYMMDD") & ".xls"

If strFn = strFn & "_" & FromDate - ToDate & ".xls" Then
ExtractNewFileName = strFn
Else
ExtractNewFileName = "nothing found"
End If

End Function

 

[JLGWhiz]

This should return the last eight characters of the file name minus the 4
digit file extension. If you are using xl2007, change the 11 to 12.

Mid(FileName,Len(FileName)-11, 8) >=20071201 And
Mid(FileName,Len(FileName)-11, 8) <= 20071212

Looks a little cumbersome but I believe it will return your dates. I have
not tried it so be careful.

 

[RompStar]

This is how I have it now. I tried to step into the Sub in the VBE,
but it won't let me, nothing is happening,
and the Sub don't show as a Marco that I can play, so I think I am
doing something wrong:


Sub FileFound(strFileName As String)

Dim path As Variant

Set fs = Application.FileSearch

With fs
.LookIn = "c:\Kevin\"
.SearchSubFolders = True
.Filename = strFileName & "*.txt"
.FileType = msoFileTypeAllFiles
If .Execute() > 0 Then
MsgBox "There were " & .FoundFiles.Count & " file(s) found."
Else
MsgBox "There were no files found."
End If

ActiveSheet.Range("A1") =
Application.Transpose(ExtractNewFileName(strFileName))
Cells.EntireColumn.AutoFit

End With

End Sub




Function ExtractNewFileName(Filename As String) As String

Dim strFn As String

strFn = Mid(Filename, Len(Filename) - 11, 8) >= 20071201 And
Mid(Filename, Len(Filename) - 11, 8) <= 20071212

ExtractNewFileName = strFn

End Function