Sub Макрос1()
    On Error GoTo Err0
    
    Dim path_dbf As String:     path_dbf = ThisWorkbook.Path
    Dim basa_dbf As String:     basa_dbf = "trpr.dbf"
    
    Dim cnn As ADODB.Connection
    Dim rst As ADODB.Recordset
    
    Set cnn = New ADODB.Connection
    cnn.ConnectionString = "DRIVER={Microsoft dBase Driver (*.dbf)};" & "DBQ=" & path_dbf & ";" & "DefaultDir=" & path_dbf & "\"
    cnn.Open
    Set rst = New ADODB.Recordset
    rst.Open "SELECT * FROM " & basa_dbf, cnn
    
    Application.ScreenUpdating = False
    
    Dim lst
    Set lst = ThisWorkbook.Worksheets("Лист1")
    
    'Создание заголовков
    Dim i As Integer
    For i =  0  To rst.Fields.Count -  1 
        lst.Cells( 1 , i +  1 ).Value = rst.Fields(i).Name
    Next i

    'Вставка рекордсета
    lst.Range("A2").CopyFromRecordset rst ' со следующей строки
    
    rst.Close
    cnn.Close
    
    Application.ScreenUpdating = True
    
    Set lst = Nothing
    Set rst = Nothing
    Set cnn = Nothing
    
    Exit Sub
    
Err0:

    MsgBox Err.Description
    Application.ScreenUpdating = True
End Sub