[Tasos]

Καλησπέρα Θανάση!

Δεν είχα τη δυνατότητα να δοκιμάσω τον παρακάτω κώδικα σε Excel 2003.

Ωστόσο νομίζω ότι είναι συμβατός με Excel 2003 και 2010.

Επίσης ο κώδικας δεν περιλαμβάνει ρουτίνες αποσφαλμάτωσης.

Με την εντολή CreateQueryTable() μπορεί να δημιουργηθεί ερώτημα που επιστρέφει τα
δεδομένα σε περιοχή του φύλλου ("παλαιού τύπου" - συμβατό με όλες τις εκδόσεις Excel).

Με την εντολή SetQueryConnection() τροποποιείται κατ΄επιλογή η σύνδεση ODBC καθώς και το
κείμενο SQL ενός υπάρχοντος ερωτήματος ("παλαιού τύπου" - όχι ListObject.QueryTable) στο τρέχον φύλλο.

Option Explicit

Sub CreateQueryTable()
    Dim QT As QueryTable
    Dim TheDir As String
    Dim tmpString As String
    Dim MyConnectionString As Variant
    Dim MySQLString As Variant
    Dim ChoosenFile As Variant
    Dim wks As Worksheet
    Dim DestCell As Range
    Dim fso As Object
    Dim ExtensionLen As Integer
    
    On Error Resume Next

    Set DestCell = Application.InputBox( _
                   "Where do you want to put the data?", _
                   "Select First data cell...", "$A$1", _
                   Application.Width / 2, Application.Height / 2, , , 8)
                   
    If Not DestCell Is Nothing Then
        Set DestCell = DestCell(1)
        Set wks = DestCell.Parent
    Else
        Exit Sub
    End If
    
    On Error GoTo 0
    
    Set fso = CreateObject("Scripting.FileSystemObject")

    ChoosenFile = Application.GetOpenFilename _
                  (Title:="Please choose source file", _
                   FileFilter:="Excel Files *.xls* (*.xls*),")
    If ChoosenFile = False Then
        MsgBox "No file selected.", vbExclamation, "!!!"
        Exit Sub
    Else
        MsgBox "Source file will be:" & vbLf & ChoosenFile
    End If

    ExtensionLen = Len(fso.GetExtensionName(ChoosenFile)) + 1

    TheDir = fso.GetParentFolderName(ChoosenFile)

    tmpString = "SELECT `Φύλλο1$`.col1, `Φύλλο1$`.col2, `Φύλλο1$`.col3, " _
                & "`Φύλλο1$`.col4, `Φύλλο1$`.col5, `Φύλλο1$`.col6 " _
                & "FROM `" & Left(ChoosenFile, Len(ChoosenFile) - ExtensionLen) & "`.`Φύλλο1$` `Φύλλο1$`"

    MySQLString = StringToArray(tmpString)

    tmpString = "ODBC;DSN=Excel Files;DBQ=" & ChoosenFile & ";DefaultDir=" & TheDir & _
                ";DriverId=790;MaxBufferSize=2048;PageTimeout=5;"
                
    MyConnectionString = StringToArray(tmpString)
    
    Set QT = wks.QueryTables.Add(Connection:=Array(MyConnectionString), Destination:=DestCell)
    
    QT.CommandType = xlCmdSql
    QT.CommandText = Array(MySQLString)
    QT.Refresh BackgroundQuery:=False
    wks.Activate
End Sub

Sub SetQueryConnection()
    Dim QT As QueryTable
    Dim TheDir As String
    Dim tmpString As String
    Dim MyConnectionString As Variant
    Dim MySQLString As Variant
    Dim ChoosenFile As Variant
    Dim fso As Object
    Dim ExtensionLen As Integer

    ChoosenFile = Application.GetOpenFilename _
                  (Title:="Please choose source file", _
                   FileFilter:="Excel Files *.xls* (*.xls*),")

    If ChoosenFile = False Then
        MsgBox "No file selected.", vbExclamation, "!!!"
        Exit Sub
    Else
        Set fso = CreateObject("Scripting.FileSystemObject")
        MsgBox "Source file will be:" & vbLf & ChoosenFile
    End If

    ExtensionLen = Len(fso.GetExtensionName(ChoosenFile)) + 1

    TheDir = fso.GetParentFolderName(ChoosenFile)

    Set QT = ActiveSheet.QueryTables(1)

    tmpString = "SELECT `Φύλλο1$`.col1, `Φύλλο1$`.col2, `Φύλλο1$`.col3, " _
                & "`Φύλλο1$`.col4, `Φύλλο1$`.col5, `Φύλλο1$`.col6 " _
                & "FROM `" & Left(ChoosenFile, Len(ChoosenFile) - ExtensionLen) & "`.`Φύλλο1$` `Φύλλο1$`"

    MySQLString = StringToArray(tmpString)

    tmpString = "ODBC;DSN=Excel Files;DBQ=" & ChoosenFile & ";DefaultDir=" & TheDir & _
                ";DriverId=790;MaxBufferSize=2048;PageTimeout=5;"
    'Debug.Print QT.Connection
    'Debug.Print tmpString
    If QT.Connection <> tmpString Then
        MyConnectionString = StringToArray(tmpString)
    Else
        MsgBox "There is already a data connection to this file!", vbInformation
        Exit Sub
    End If

    QT.Connection = Array(MyConnectionString)
    QT.CommandType = xlCmdSql
    QT.CommandText = Array(MySQLString)
    QT.Refresh BackgroundQuery:=False

End Sub

Function StringToArray(Qry As String) As Variant
' Source: http://support.microsoft.com/kb/816562
    Const StrLen = 127
    Dim NumElems As Integer
    Dim i As Double
    Dim Temp() As String

    NumElems = (Len(Qry) / StrLen) + 1
    ReDim Temp(1 To NumElems) As String

    For i = 1 To NumElems
        Temp(i) = Mid(Qry, ((i - 1) * StrLen) + 1, StrLen)
    Next i
    StringToArray = Temp
End Function

Ελπίζω να σε βοηθήσει.

Τα λέμε.

Τάσος