Help improve .DBF import speed

[andybluejay]

I am working on a project to automate importing multiple .dbf files into a single excel sheet. The idea being I can import a group of .dbf files representing one dataset and the trend/graphs I need are automatically generated. The .dbf files always have the same data columns/header (38 columns) and an undetermined amount of rows, typically around 1000 (all columns are same length); but the number of .dbf files to combine could be a low as 5 or as many as 50. Fortunately the plots I need are generally always the same. My working code is below (though I did not write the bulk of it):

Sub OpenDBF()

'clear all cells first
Cells.Select
Selection.ClearContents

Set Masterbk = ThisWorkbook
Set MasterSht = Masterbk.Sheets(1)
'get first empty column in master worksheet
MasterLastCol = MasterSht.Cells(1, Columns.Count).End(xlToLeft).Column
If MasterLastCol <> 1 Then
 MasterNewCol = MasterLastCol + 1
Else
 MasterNewCol = 1
End If

Dim chosenfolder As String
chosenfolder = GetFolder()
'Debug.Print chosenfolder
Folder = chosenfolder + "\" 'make sure backslash is in string
'Debug.Print Folder

FName = Dir(Folder & "*.dbf")

Do While FName <> ""
 Set bk = Workbooks.Open(Filename:=Folder & FName)

 Set NewSht = bk.Sheets(1)
 
 With NewSht
  'use column A to determine last row of database
  DatabaseLastRow = .Range("A" & Rows.Count).End(xlUp).Row
  
  MasterLastRow = MasterSht.Range("A" & Rows.Count).End(xlUp).Row
  MasterNewRow = MasterLastRow + 1
  LastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
  
  
  For ColCount = 1 To LastCol
   Header = .Cells(1, ColCount)
   Set DataBaseColumn = _
   .Range(.Cells(2, ColCount), .Cells(DatabaseLastRow, ColCount))
   
   With MasterSht
   'check if header exists
   Set c = .Rows(1).Find(what:=Header, _
    LookIn:=xlValues, lookat:=xlWhole)
   If c Is Nothing Then
    .Cells(1, MasterNewCol) = Header
    DataBaseColumn.Copy _
     Destination:=.Cells(MasterNewRow, MasterNewCol)
    MasterNewCol = MasterNewCol + 1
   Else
    DataBaseColumn.Copy _
     Destination:=.Cells(MasterNewRow, c.Column)
   End If
   
   End With
  Next ColCount
 End With
 
 bk.Close savechanges:=True

 FName = Dir()
Loop

'Call deleteEmpty
'Call tagColumns
'Call dateTime
'Call nameAdd

End Sub

While technically everything that I need works... it is very very slow. A single .dbf file takes about 3min to import, and a group of 15-20 takes about an hour (on a i7-10610U / 16GB ram). I feel like the runtime could be greatly improved, simply dragging and dropping a .dbf into excel opens it instantly. So far I have failed to make meaningful changes to the code without breaking it. My thought was, instead of parsing each column, find the last row of the next .dbf, copy the range A2 through AL*lastrow*, paste selection after the current last row of the sheet in the master workbook.

I feel like this should be easy to implement, but my knowledge of VBA syntax is terrible. Hoping someone could point me in the right direction.

 

[GWteB]

Hi & welcome to MrExcel!

See whether this helps you ...

Public Sub andybluejay()

    Dim ShtDest As Worksheet
    Set ShtDest = ThisWorkbook.Worksheets.Add

    Dim DBFolder As String
    DBFolder = GetFolder() & "\"

    Dim DBFileName As String
    DBFileName = VBA.Dir(DBFolder & "*.dbf")

    If VBA.Len(DBFileName) > 0 Then
    
        With Application
            .ScreenUpdating = False
            .EnableEvents = False
            .Calculation = xlCalculationManual
    
            ' open first DBF file
            Dim ShtSource As Worksheet
            Set ShtSource = .Workbooks.Open(Filename:=DBFolder & DBFileName).Sheets(1)
            ' keep headers & copy data
            ShtSource.UsedRange.Copy ShtDest.Cells(1, 1)
            ' close source DBF, no need for saving
            ShtSource.Parent.Close SaveChanges:=False
            
            DBFileName = Dir()
            Do While VBA.Len(DBFileName) > 0
                ' open next DBF file if there is one
                Set ShtSource = .Workbooks.Open(Filename:=DBFolder & DBFileName).Sheets(1)
                ' delete headers
                ShtSource.Rows("1:1").Delete
                'use column A to determine last row of database
                ShtSource.UsedRange.Copy ShtDest.Cells(ShtDest.Rows.Count, "A").End(xlUp).Offset(1, 0)
                ' close source DBF, no need for saving
                ShtSource.Parent.Close SaveChanges:=False
                
                DBFileName = VBA.Dir()
                VBA.DoEvents
            Loop
            ShtDest.Columns.AutoFit
            .Calculation = xlCalculationAutomatic
            .EnableEvents = True
            .ScreenUpdating = True
        End With
    End If
    
    'Call deleteEmpty
    'Call tagColumns
    'Call dateTime
    'Call nameAdd
End Sub

 

[andybluejay]

Didn't have a change to look at this over the weekend with the holiday and all... It works perfect! I'm thrilled, Can't thank you enough. Truly a much more elegant way to accomplish what I needed. My biggest group of .dbf's take less than a minute to open and format.

 

[GWteB]

You are welcome and thanks for the feedback