Trouble looping through .dbf files

[JimmyMack]

So I'm banging my head against the wall trying to run a macro that generates a new worksheet for every .dbf file in specified directory and then copies ranges of data. The code works great for the first file but then gets hung up on that first .dbf and never advances to the subsequent files. I'm sure its a simple fix, but I'm still relatively green.

Any help would be much appreciated!



Sub LoopFiles()
Dim strDir As String, strFileName As String, strDBFs As String
Dim wbSourceBook As Workbook, wbTargetBook As Workbook
Dim wsTemplate As Worksheet, wsNewSheet As Worksheet
Dim DBFnum As Integer

strDir = "C:\Users\JMack\Desktop\WaterQuality\TempDBFs\"
strFileName = Dir(strDir & "*.dbf")
strSiteName = Left(strFileName, (InStrRev(strFileName, ".", -1, vbTextCompare) - 1))

Set wbTargetBook = ThisWorkbook
Set wsTemplate = wbTargetBook.Sheets(1)

Do While strFileName <> ""

Dim i As Integer
i = 1

''Add new worksheet based on exceedence table template
wsTemplate.Copy after:=wbTargetBook.Worksheets(i)
Set wsNewSheet = wbTargetBook.Sheets(i + 1)
wsNewSheet.Name = "test"

Set wbSourceBook = Workbooks.Open(strDir & strFileName)

''There is more code in the middle but not pertinent to the issue

i = i + 1
strFileName = strDir()
wbSourceBook.Close savechanges:=False

Loop

'Application.ScreenUpdating = True
'Application.DisplayAlerts = True

End Sub

 

[Trevor G]

Welcome to teh Forum Jimmy, What if you adjust the

Do While MyFile <> ""
If MyFile Like "*.dbf" Then.

This sample code works for copying data into a single sheet but I would imagine you can adjust it to your needs.

Sub Open_My_Files()
Dim mypath As String
Dim MyFile As String
mypath = "M:\Access Files\"
MyFile = Dir(mypath)
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False

Do While MyFile <> ""
If MyFile Like "*.xls" Then
Workbooks.Open mypath & MyFile
Sheets(1).UsedRange.Copy

ActiveWorkbook.Close True
Range("A1").Select
Range("A" & Rows.Count).End(xlUp).Select
ActiveCell.Offset(1, 0).PasteSpecial xlPasteAll

Cells.PasteSpecial xlPasteAll

End If
MyFile = Dir
Loop
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
End Sub

 

[JimmyMack]

Thanks for the reply. I adjusted the code as follows (I believe this is what you were recommending) but am still having the same issue. The "Do while" loop completes the first iteration and then attempts to run again using the same .dbf file.


Sub LoopFiles()
Dim strDir As String, strFileName As String, strDBFs As String
Dim wbSourceBook As Workbook, wbTargetBook As Workbook
Dim wsTemplate As Worksheet, wsNewSheet As Worksheet
Dim DBFnum As Integer

strDir = "C:\Users\JMack\Desktop\WaterQuality\TempDBFs\" 'specify folder to search
'strFileName = Dir(strDir & "*.dbf")
strFileName = Dir(strDir)
strSiteName = Left(strFileName, (InStrRev(strFileName, ".", -1, vbTextCompare) - 1))

'Application.ScreenUpdating = False
'Application.Calculation = xlCalculationManual
'Application.DisplayAlerts = False

Set wbTargetBook = ThisWorkbook
Set wsTemplate = wbTargetBook.Sheets(1)

Do While strFileName <> ""
If strFileName Like "*.dbf" Then

Dim i As Integer
i = 1

''Add new worksheet based on exceedence table template
wsTemplate.Copy after:=wbTargetBook.Worksheets(i)
Set wsNewSheet = wbTargetBook.Sheets(i + 1)
wsNewSheet.Name = strSiteName

Set wbSourceBook = Workbooks.Open(strDir & strFileName)

''...
''...

i = i + 1
End If

strFileName = Dir
'wbSourceBook.Close savechanges:=False

Loop

'Application.ScreenUpdating = True
'Application.Calculation = xlCalculationAutomatic
'Application.DisplayAlerts = True

End Sub

 

[JimmyMack]

Nevermind! The issue was not with the loop it was that I defined strSiteName outside/before the loop and so it was not updating with each new file. Stupid mistake. Thanks for the help.