Looping thru Files In FolderSub

[Jim May]

I see my error, but don't know how to fix it.
Can someone assist?
TIA

Sub ExtractDataFromFiles()
Const sPath = "C:\Documents and Settings\Test\"
Dim sName As String
Dim wb As Workbook
Dim j As Integer
Dim n As Integer
Dim r(1 To 14) As Variant
' Load UserForm1
' UserForm1.Show False 'Your Macro is Running
'Application.ScreenUpdating = False
'Application.DisplayAlerts = False
sName = Dir(sPath & "*.xls")
j = 6 ' Data starts on Row 6
Do While sName <> ""
sName = Dir(sPath & "*.xls") <<<<<<<< File Name Not Changing
because of Line 12
Set wb = Workbooks.Open(sPath & sName)
With wb.Worksheets("Cost Analysis")
r(1) = .Range("J2").Value
r(2) = .Range("B4").Value
r(3) = .Range("B6").Value
r(4) = .Range("G4").Value
r(5) = .Range("G6").Value
r(6) = .Range("G6").Value
r(7) = .Range("J1").Value
r(8) = .Range("G51").Value
r(9) = .Range("G53").Value
r(10) = .Range("G54").Value
r(11) = .Range("G56").Value
r(12) = .Range("G57").Value
r(13) = .Range("G58").Value
r(14) = .Range("G59").Value
End With
wb.Close SaveChanges:=False
With ThisWorkbook.ActiveSheet
For n = 1 To 14
.Cells(j, n).Value = r(n)
Next n
End With
j = j + 1
'End If
'Set wb = Nothing
Loop
End Sub

 

[Tom Ogilvy]

It is usually done like this. Subsequent calls to Dir have no argument. by
putting in an argument, you are starting back over at the first file.

Sub ExtractDataFromFiles()
Const sPath = "C:\Documents and Settings\Test\"
Dim sName As String
Dim wb As Workbook
Dim j As Integer
Dim n As Integer
Dim r(1 To 14) As Variant
' Load UserForm1
' UserForm1.Show False 'Your Macro is Running
'Application.ScreenUpdating = False
'Application.DisplayAlerts = False
sName = Dir(sPath & "*.xls")
j = 6 ' Data starts on Row 6
Do While sName <> ""
Set wb = Workbooks.Open(sPath & sName)
With wb.Worksheets("Cost Analysis")
r(1) = .Range("J2").Value
r(2) = .Range("B4").Value
r(3) = .Range("B6").Value
r(4) = .Range("G4").Value
r(5) = .Range("G6").Value
r(6) = .Range("G6").Value
r(7) = .Range("J1").Value
r(8) = .Range("G51").Value
r(9) = .Range("G53").Value
r(10) = .Range("G54").Value
r(11) = .Range("G56").Value
r(12) = .Range("G57").Value
r(13) = .Range("G58").Value
r(14) = .Range("G59").Value
End With
wb.Close SaveChanges:=False
With ThisWorkbook.ActiveSheet
For n = 1 To 14
.Cells(j, n).Value = r(n)
Next n
End With
j = j + 1
'End If
'Set wb = Nothing
'
' added line
'
sName = Dir
Loop
End Sub

 

[Jim May]

Thanks Tom;
I'll read through..
Jim

It is usually done like this. Subsequent calls to Dir have no argument. by
putting in an argument, you are starting back over at the first file.

Sub ExtractDataFromFiles()
Const sPath = "C:\Documents and Settings\Test\"
Dim sName As String
Dim wb As Workbook
Dim j As Integer
Dim n As Integer
Dim r(1 To 14) As Variant
' Load UserForm1
' UserForm1.Show False 'Your Macro is Running
'Application.ScreenUpdating = False
'Application.DisplayAlerts = False
sName = Dir(sPath & "*.xls")
j = 6 ' Data starts on Row 6
Do While sName <> ""
Set wb = Workbooks.Open(sPath & sName)
With wb.Worksheets("Cost Analysis")
r(1) = .Range("J2").Value
r(2) = .Range("B4").Value
r(3) = .Range("B6").Value
r(4) = .Range("G4").Value
r(5) = .Range("G6").Value
r(6) = .Range("G6").Value
r(7) = .Range("J1").Value
r(8) = .Range("G51").Value
r(9) = .Range("G53").Value
r(10) = .Range("G54").Value
r(11) = .Range("G56").Value
r(12) = .Range("G57").Value
r(13) = .Range("G58").Value
r(14) = .Range("G59").Value
End With
wb.Close SaveChanges:=False
With ThisWorkbook.ActiveSheet
For n = 1 To 14
.Cells(j, n).Value = r(n)
Next n
End With
j = j + 1
'End If
'Set wb = Nothing
'
' added line
'
sName = Dir
Loop
End Sub

--
Regards,
Tom Ogilvy

:

 

[Jim May]

If I wished to qualify the *.xls that are opened/considered to only be
files which start with the same two letters "PA", (meaning
I want only files such as PA05Abc-1.xls; PA06123.xls; PA 057122-BB.xls)..
how would I do that?
Tks,
Jim

 

[Tom Ogilvy]

Sub abc()
cnt = 0
sName = Dir("E:\Data\PA*.xls")
Do While sName <> ""
cnt = cnt + 1
Debug.Print sName
sName = Dir
Loop
Debug.Print cnt
End Sub