Forum - VBA Ενημέρωση συνολικού αρχείου

Γιώργο καλημέρα!
Για να προσθέσεις δεδομένα στο βιβλίο F:\SALES\Total\Total_Report.xls από πηγή με σταθερή διαδρομή
(πχ. F:\SALES\Total\Sales_Report.xls), και ταυτόχρονα να ελέγχεις όλες τις γραμμές στο και από τα δυο βιβλία
για τυχόν διπλότυπες εγγραφές, θα σου πρότεινα:

Στο συγκεντρωτικό βιβλίο (Total\Sales_Report.xls) να δημιουργήσεις ένα νέο φύλλο όπου με χρήση της λειτουργίας "Εισαγωγή εξωτερικών δεδομένων» (επιλέγοντας:
Εισαγωγή εξωτερικών δεδομένων > Δημιουργία Ερωτήματος σε βάση δεδομένων)
θα μπορέσεις με τη βοήθεια του οδηγού να εισάγεις τα δεδομένα της βιβλίου-πηγής
και να τα ανανεώνεις όποτε θελήσεις (πχ. όταν παραλάβεις το νέο Total\Sales_Report.xls).

Αφού κάνεις αυτό θα χρειαστείς:

Τύπος 1 : Τύπος που θα ενώνει τα περιεχόμενα των 17 στηλών (A – Q) και του συγκεντρωτικού φύλλου αλλά και του νέου φύλλου που περιέχει τα δεδομένα από την εξωτερική πηγή.

Τύπος2. Τύπος που θα αναζητεί διπλότυπες εγγραφές χρησιμοποιώντας τα αποτελέσματα του τύπου1.

Ο τύπος2 χρησιμοποιεί μια παλιά αλλά πολύ λειτουργική συνάρτηση που την έχω ονομάσει "Try" που στην πράξη επιταχύνει τον έλεγχο διπλότυπων κατά 45% περίπου.
Δεν θα ήθελα να την περιγράψω στο μήνυμα αυτό για να μην ξεφύγω από το κυρίως θέμα αλλά αν κάποιος έχει απορίες πάνω σ αυτό μπορεί να ρωτήσει στο φόρουμ.

Επίσης θα χρειαστεί κώδικας VBA που θα εισάγει τα έγκυρα δεδομένα στο συγκεντρωτικό φύλλο.

Νομίζω ότι είνα καλύτερα να δείς το συνημμένο γιατί... μια εικόνα = 1000 λέξεις!

Γενικότερα κώδικας που που είναι απαραίτητος για να λειτουργήσει το στο συνημμένο παράδειγμα (περιέχεται ήδη) είναι ο εξής:

Κώδικας:

Option Explicit
 

Sub ChangeQueryConnection()

    Dim ThePath As String, TheDir As String, MyArr

    With Application.FileDialog(msoFileDialogOpen)

        .Filters.Clear

        .Filters.Add "Excel Files", "*.xls"

        If .Show Then

            ThePath = .SelectedItems(1)

            TheDir = Left(ThePath, Len(ThePath) - InStr(1, StrReverse(ThePath), "\"))

        Else

            Exit Sub

        End If

    End With

    MyArr = "SELECT `Sheet1$`.`ΕΒΔΟΜΑΔΙΑΙΑ ΕΚΘΕΣΗ`, `Sheet1$`.F2, `Sheet1$`.F3, " _

            & ";`Sheet1$`.F4, `Sheet1$`.F5, `Sheet1$`.F6, `Sheet1$`.F7, `Sheet1$`.F8, " _

            & ";`Sheet1$`.F9, `Sheet1$`.F10, `Sheet1$`.F11, `Sheet1$`.F12, `Sheet1$`.F13, " _

            & ";`Sheet1$`.F14, `Sheet1$`.F15, `Sheet1$`.F16, `Sheet1$`.F17 " _

            & ";FROM `" & Left(ThePath, Len(ThePath) - 4) & "`.`Sheet1$` `Sheet1$`"

    MyArr = Split(MyArr, ";")

    With ImportSheet.QueryTables(1)

        .Connection = _

        "ODBC;DSN=Excel Files;DBQ=" & ThePath & ";DefaultDir=" & TheDir & _

                      ";DriverId=790;MaxBufferSize=2048;PageTimeout=5;"

        .CommandText = Array(MyArr)

        Debug.Print .CommandText

        .Refresh BackgroundQuery:=False

    End With

End Sub
 

Sub RefreshData()

    Dim Formulas_were_enabled As Boolean

    On Error GoTo ErrH

    With Application

        .Calculation = xlCalculationManual

        .ScreenUpdating = False

        Formulas_were_enabled = Left(Range("FirstFormula"), 1) <> "$"

        If Formulas_were_enabled Then DisableFormulas
 

        ImportSheet.QueryTables(1).Refresh BackgroundQuery:=False

ErrH:

        .Calculation = xlCalculationAutomatic

        If Formulas_were_enabled Then EnableFormulas

        If Err Then MsgBox Err & vbLf & Err.Description

    End With

End Sub
 

Sub CopyData()

    Dim rngSource As Range, rngTarget As Range

    If Range("DuppsCounter") = 0 Then

    DisableFormulas

        With DataSheet

            If .FilterMode Then .ShowAllData

            Set rngTarget = .Range("A" & .Rows.Count).End(xlUp).Offset(1)

        End With

        With ImportSheet

            Set rngSource = .Range("A3:Q" & .Range("Q" & .Rows.Count).End(xlUp).Row)

        End With

        If rngSource.Row > 2 Then

            rngSource.Copy

            rngTarget.PasteSpecial xlPasteValues

            Application.CutCopyMode = False

        End If

    End If

End Sub
 

Sub DisableFormulas()

    With DataSheet.Range("AE5:AG5000")

        .Replace What:="=", Replacement:="§", LookAt:=xlPart, _

                 SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _

                 ReplaceFormat:=False

    End With

End Sub
 

Sub EnableFormulas()

    With DataSheet.Range("AE5:AG5000")

        .Replace What:="§", Replacement:="=", LookAt:=xlPart, _

                 SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _

                 ReplaceFormat:=False

    End With

End Sub

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

Δες αρχικά το συνημμένο και ακολούθησε τα 3 βήματα για να δεις τη λειτουργία του.

Αν κάτι δε σου λειτουργήσει, απλά γράψε στο φόρουμ.

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

Τάσος