Sub DBF()
    Dim Arr()
    Dim p As String, f As String, wb As Workbook
    Dim sFileName, sTempFileName As String
    Application.ScreenUpdating = False: Application.DisplayAlerts = False
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Выбрать папку": .Show
        If .SelectedItems.Count = 0 Then
            Exit Sub
        Else
            p = .SelectedItems(1) & "\"
        End If
    End With
    f = Dir(p & "*.dbf")
  
    Do While f <> ""
        sFileName = f
        sTempFileName = "123456.dbf"
        Name p + sFileName As p + sTempFileName
       
        Dim cn As New ADODB.Connection, rs As New ADODB.Recordset

        With cn
            .Provider = "Microsoft.Jet.OLEDB.4.0"
            .ConnectionString = "Data Source=" & p & ";Extended Properties=dBase IV"
            .Open
            Set rs = .Execute("SELECT * FROM " & sTempFileName)
            Arr ()= rs.Fields.Item(1).Value
            .Close
        End With
        
        Name p + sTempFileName As p + sFileName
        f = Dir
    Loop
End Sub