Call and list Specific Files Under One Directory

[maperalia]

I wonder If somebody can help me with this matter.
I have a program that finds the “lst†files located under the directory
described on the cellâ€C3â€.
However, when I call these files I got all the files located under this
directory where sometimes more than 1000 files are found under this
directory. The fact is that I just need three or four of them.

I have been trying to make it run accordingly what I need (see macro below).
However, I could not make it work. I wonder if I can get just the files I
need. For example, if the cell “C3†has the description AAAA, cell “C5†has
the description G20, and the cell “C6†has the description 100. I want to
call the files under the directory AAAA which have the following files:
G20@100A
G20@100B
G20@100C
G20@100D
Sometimes, there are just three of them (A, B, and C) and sometimes are four
(A, B, C, and D).
Could you please check my program and let me know where I am failing because
I can not make it run.

Thanks in advance.
Maperalia





'***********************************************************************
‘Start Program
Sub List_lst_Files()

Dim FName As String
Dim r As Integer
Dim i As Long
Dim MyPath As String
Dim WO As String
Dim EXCAVATION As String
Dim depth As String
Dim Filename As String
Dim PostLetter As String

Const strFileType As String = "lst" '<<===== CHANGE
'With ActiveSheet.Columns(1)
'.Hyperlinks.Delete
'.ClearContents
'End With

Application.ScreenUpdating = False
WO = Worksheets("DEFAULTS").Range("C3")
'WO = Application.InputBox("Enter Work Order Number")



EXCAVATION = Worksheets("DEFAULTS").Range("C5")
depth = Worksheets("DEFAULTS").Range("C6")
PostLetter = A,B,C,D
Filename = "" & EXCAVATION & "& ""@"" &" & depth & """PostLetter"""
MyPath = "S:\GEOTEST\shears\" & WO & "\" & Filename & ".lst"




On Error Resume Next
Worksheets("List of lst Files").Delete
On Error GoTo 0
Application.DisplayAlerts = False
Worksheets.Add.Name = "List of lst Files"

Application.ScreenUpdating = False
r = 2
With Application.FileSearch
.NewSearch
.LookIn = MyPath
.SearchSubFolders = True
.Filename = "*." & strFileType
If .Execute() > 0 Then
For i = 1 To .FoundFiles.Count
FName = Mid(.FoundFiles(i), 1)
Cells(r, 1) = Mid(FName, Len(MyPath) + 1, 255)




Application.ScreenUpdating = False
r = r + 1
Next i
End If
End With

'*************************************************************************************************
'FORMAT CELLS
Application.ScreenUpdating = False
ActiveSheet.Select
Columns("A:A").ColumnWidth = 20
Columns("A:A").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With



Dim myCell As Range
Dim myStr As String

Range("A1").Select
Set myCell = Worksheets("defaults").Range("C3")

myStr = "=""LST Files Found Under ""&" & myCell.Address(external:=True)
& "&"" Directory"""

ActiveCell.Formula = myStr

End Sub

‘End Program
'***********************************************************************

 

[JLatham]

Sorry, I'm kind of an old fashioned type, so I didn't even mess with
..FileSearch and came up with this for you:

Sub List_lst_Files()
Const basicPath = "S:\GEOTESTS\shears\"
Const listSheetName = "List of lst Files"
Dim anyFileName As String
Dim searchFor As String
Dim rOffset As Long
Dim listBaseCell As Range

'test for existing sheet named 'List of lst Files'
On Error Resume Next
Worksheets(listSheetName).Cells.Clear
If Err <> 0 Then
Err.Clear
On Error GoTo 0
Worksheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = listSheetName
End If
On Error GoTo 0
Set listBaseCell = Worksheets(listSheetName).Range("A1")

'build path/name that looks like
'S:\GEOTEST\shears\AAAA\G20@100*.lst"
'to use as mask for DIR$() function
searchFor = basicPath & _
Worksheets("DEFAULTS").Range("C3").Value & "\" & _
Worksheets("DEFAULTS").Range("C5").Value & "@" & _
Worksheets("DEFAULTS").Range("C6").Value & "*.lst"
anyFileName = Dir$(searchFor)
Do While anyFileName <> ""
listBaseCell.Offset(rOffset, 0) = anyFileName
rOffset = rOffset + 1
anyFileName = Dir$ ' gets next match for original 'mask'
Loop
set listBaseCell = Nothing ' release resource
End Sub

 

[maperalia]

JLatham;
Thanks very much. It is working PERFECTLY!!!!!

Maperalia

 

[JLatham]

Sometimes the old ways are the easier ways... at least for me. Glad I could
help.

As I said, I don't use the .FileSearch myself, so I could be totally off
base here, but I think maybe the development of the filename and path as you
were doing may have been creating a path\filename that was confusing things.
Not sure, didn't test it. It just looks a whole lot more complex than
anything should ever look, whether it's right or not

 

[maperalia]

JLatham;
I have been running the program without problem. However, last time I made a
mistake and click the macro twice. So I saw that everything was completely
twisted. Well my file is as read only so I did not have problem to restore it.

I wonder if you can give and statement to avoid this problem. For example,
ii I click the first time will create the sheet with the list; however, if I
click after the first time will delete the sheet and create the same one or
do nothing.

The previous macro I had has the following statement:

On Error Resume Next
Application.DisplayAlerts = False
Worksheets("List of lst Files").Delete
On Error GoTo 0
Application.DisplayAlerts = False
Worksheets.Add.Name = "List of lst Files"
Application.DisplayAlerts = True

This statement works find in the previous macro; however, I have tried to
make it work in the macro you sent me and are not working.

Could you please help me to adjust it?

Thanks.
Maperalia

 

[maperalia]

JLaham;
Do do not worry I made it run!!!!!

Thanks anyway for you help.

Maperalia

 

[JLatham]

So you're good to go now?

JLaham;
Do do not worry I made it run!!!!!

Thanks anyway for you help.

Maperalia