[VBA] Αλλαγή πηγής δεδομένων

[gr8styl]

Καλημέρα
στο συνημμένο zip έχω 3 αρχεία
Τα Source01.xls και Source02.xls είναι αρχεία/πηγή δεδομένων.
Το vba_qry_ChgSrc.xlsm είναι το κύριο αρχείο που περιέχει και τον κώδικα
Βασικά το κύριο αρχείο κάνει εισαγωγή δεδομένων από το πρώτο αρχείο/πηγή δεδομένων (με ανανέωση δεδομένων).
Με κώδικα ο χρήστης μπορεί να επιλέξει το αρχείο πηγή δεδομένων και γίνεται ανανέωση δεδομένων με την νέα επιλεγμένη πηγή.

Προς το παρόν ο κώδικας είναι συμβατός μόνο με 2010 και όχι με 2003, διότι στο 2010 το QueryTable είναι στοιχείο του ListObject ενώ στο 2003 είναι στοιχείο του Worksheet

Θα ήθελα την βοήθειά σας τόσο για την βελτίωση του κώδικα όσο και την δυνατότητα να μπορεί να εκτελείται σε 2003 και 2010.

Ευχαριστώ εκ των προτέρων
Θανάσης

ΥΓ Για να το δοκιμάσετε, αποσυμπιέστε το zip στο directory: C:\temp\change_source\

[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

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

Τα λέμε.

Τάσος

[gr8styl]

Καλημέρα σε όλους και όλες.

Τάσε σε ευχαριστώ πολύ.
Σαφώς βοήθησε για μια ακόμα φορά μας έδειξες διάφορες τεχνικές και κόλπα όπως πάντα με τους κώδικές σου.
Το δοκίμασα και δουλεύει και σε 2003 χωρίς πρόβλημα.

Το πρόβλημά μου είναι ότι θα προτιμούσα να μην μπλεχτώ με τις λεπτομέρειες του CommandText και του Connection string στον κώδικα, γι αυτό και είχα χρησιμοποίησει το Application.substitute.
Μια προσέγγιση OldSource NewSource θα με βόλευε πολύ περισσότερο.

Ευχαριστώ και πάλι για το χρόνο σου.

[Tasos]

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

Θα πρότεινα τα εξής!
Δώσε σε ένα κελί οπουδήποτε στο βιβλίο εργασίας το όνομα "OldSrc" Μπορεί να είναι κρυφό ή βρίσκεται σε κρυμμένο φύλλο εργασίας. Δεν πρέπει να είναι κλειδωμένο.

Στην εντολή CreateQueryTable() πρόσθεσε στο τέλος τη γραμμή: Range("OldSrc").Value = ChoosenFile

Επίσης στην εντολή αυτή (στο προηγούμενο μου μήνυμα) μετέτρεψα την έκφραση:

tmpString = "ODBC;DSN=Excel Files;DBQ=" & MyConnectionString & ";DefaultDir=" & TheDir & _
                ";DriverId=790;MaxBufferSize=2048;PageTimeout=5;"

σε

tmpString = "ODBC;DSN=Excel Files;DBQ=" & ChoosenFile & ";DefaultDir=" & TheDir & _
                ";DriverId=790;MaxBufferSize=2048;PageTimeout=5;"

Για την αλλαγή πηγής δεδομένων με αντικατάσταση της διαδρομής του αρχείου στη σύνδεση ODBC και το κείμενο SQL τροποποίησα την εντολή SetQueryConnection() όπως φαίνεται παρακάτω:

Sub SetQueryConnection()
' Για να λειτουργήσει θα πρέπει το κελί "OldSrc" να περιέχει την διαδρομή προς αλλαγή.
' Ίσως την πρώτη φορά να χρειαστεί να συμπληρωθεί με το χέρι.
    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
    Dim ExtensionLenOld As Integer
    Dim OldSrc As String

    OldSrc = Range("OldSrc").Value

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

    If ChoosenFile = False Then
        MsgBox "No file selected.", vbExclamation, "!!!"
        Exit Sub
    ElseIf OldSrc = ChoosenFile Then
        MsgBox "There is already a data connection to this file!", vbInformation
        Exit Sub
    Else
        Set fso = CreateObject("Scripting.FileSystemObject")
        MsgBox "Source file will be:" & vbLf & ChoosenFile
    End If

    ExtensionLen = Len(fso.GetExtensionName(ChoosenFile)) + 1
    ExtensionLenOld = Len(fso.GetExtensionName(OldSrc)) + 1
    
    TheDir = fso.GetParentFolderName(ChoosenFile)

    Set QT = ActiveSheet.QueryTables(1)
       Debug.Print QT.CommandText
       Debug.Print QT.Connection
    tmpString = Replace(QT.CommandText, Left(OldSrc, Len(OldSrc) - ExtensionLenOld) _
                                       , Left(ChoosenFile, Len(ChoosenFile) - ExtensionLen))

    MySQLString = StringToArray(tmpString)

    tmpString = Replace(QT.Connection, OldSrc, ChoosenFile)
    
    QT.Connection = Array(MyConnectionString)
    QT.CommandType = xlCmdSql
    QT.CommandText = Array(MySQLString)

    QT.Refresh BackgroundQuery:=False
    
    Range("OldSrc").Value = ChoosenFile
    
End Sub

Καλή συνέχεια!

Τάσος

[gr8styl]

Τάσε σε ευχαριστώ πολύ.