Help improve .DBF import speed

andybluejay

New Member
Joined
Dec 22, 2021
Messages
4
Office Version
  1. 365
  2. 2019
  3. 2016
Platform
  1. Windows
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):

VBA Code:
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.
 

Excel Facts

What does custom number format of ;;; mean?
Three semi-colons will hide the value in the cell. Although most people use white font instead.
Hi & welcome to MrExcel!

See whether this helps you ...
VBA Code:
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
 
Upvote 0
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.
 
Upvote 0
You are welcome and thanks for the feedback (y)
 
Upvote 0

Forum statistics

Threads
1,218,739
Messages
6,144,209
Members
450,530
Latest member
Echidnadsn

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top