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

Forum (https://www.ms-office.gr/forum/)

- Excel - Ερωτήσεις / Απαντήσεις (https://www.ms-office.gr/forum/excel-erotiseis-apantiseis/)

- - [VBA] Αλλαγή πηγής δεδομένων (https://www.ms-office.gr/forum/excel-erotiseis-apantiseis/2592-allagi-pigis-dedomenon.html)

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

Καλημέρα
στο συνημμένο 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\

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

Δεν είχα τη δυνατότητα να δοκιμάσω τον παρακάτω κώδικα σε 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

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

Τα λέμε.

Τάσος

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

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

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

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

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

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

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

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

Κώδικας:

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

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

Τάσος

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