[Tasos]

Καλημέρα σε όλους!
Σε περιπτώσεις που για κάποιο λόγο χρειαστεί επανασύνδεση ή και για τη δημιουργία νέου ερωτήματος/σύνδεσης
σε εξωτερική πηγή δεδομένων τύπου *.DBF, αφού επιλέξουμε το επιθυμητό φύλλο
στην Excel (νέο ή με ήδη υπάρχουσα σύνδεση), μπορούμενα χρησιμοποιηήσουμε τον παρακάτω παραδειγματικό κώδικα:

Ελπίζω να σας φανεί χρήσιμος!

Sub SetNewDBFConnection()

    Dim ArrSQL, wks As Worksheet, cnn, DbfFile As String, BaseNameDbfFile As String, fso As Object



    Set wks = ActiveSheet

    Set fso = CreateObject("Scripting.FileSystemObject")

    DbfFile = GetDBFFile

    If DbfFile = vbNullString Then Exit Sub



    cnn = "OLEDB;Provider=Microsoft.Jet.OLEDB.4.0;Password="  """;User ID=Admin;Data Source=,"

    cnn = cnn & Replace(fso.GetParentFolderName(DbfFile) & "\", "\\", "\")

    cnn = cnn & ";Mode=Share Deny Write;Extended Properties="""";Jet OLEDB:" _

          & "System database="""";Jet OLEDB:Registry Path="""";Jet OLEDB:Database " _

          & "Password="""";Jet OLEDB:Engine Type=18;Jet OLEDB:Database Locking ," _

          & "Mode=0;Jet OLEDB:Global Partial Bulk Ops=2;Jet OLEDB:Global " _

          & "Bulk Transactions=1;Jet OLEDB:New Database Password="""";Jet OLEDB:," _

          & "Create System Database=False;Jet OLEDB:Encrypt Database=False;Jet " _

          & "OLEDB:Don't Copy Locale on Compact=False;Jet OLEDB:Compact Wit," _

          & "hout Replica Repair=False;Jet OLEDB:SFP=False"

    cnn = Split(cnn, ",")



    If wks.QueryTables.Count > 0 Then

        wks.QueryTables(1).Connection = Array(cnn)

    Else

        wks.QueryTables.Add Connection:=Array(cnn), Destination:=Range("A1")

    End If



    BaseNameDbfFile = fso.GetBaseName(DbfFile)



    ArrSQL = "SELECT DISTINCTROW [PP1], CDate([PP6]) AS MyDate, CDate([PP7]) AS MyDate1 " _

             & "FROM [" & BaseNameDbfFile & "|] " _

             & "GROUP BY [PP1],[PP6], [PP7] " _

             & "ORDER BY CDate([PP6])"  ' μπορεί να προσαρμοστεί



    ArrSQL = Split(ArrSQL, "|")



    With wks.QueryTables(1)

        .CommandType = xlCmdSql

        .CommandText = Array(ArrSQL)

        .RowNumbers = False

        .FillAdjacentFormulas = True

        .PreserveFormatting = True

        .RefreshOnFileOpen = False

        .BackgroundQuery = True

        .RefreshStyle = xlInsertDeleteCells

        .SavePassword = False

        .SaveData = True

        .AdjustColumnWidth = True

        .RefreshPeriod = 0

        .PreserveColumnInfo = True

        .SourceDataFile = DbfFile

        .Name = BaseNameDbfFile

        .Refresh BackgroundQuery:=False

    End With



End Sub



Function GetDBFFile() As String

    Dim fld As FileDialog

    Set fld = Application.FileDialog(msoFileDialogFilePicker)

    With fld

        .Filters.Clear

        .Filters.Add "DBF Files", "*.DBF"

        If .Show Then GetDBFFile = .SelectedItems(1)

    End With

End Function