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

[Flashgordon61]

Παρακαλώ τη βοήθειά σας.
Λαμβάνω σε εβδομαδιαία βάση από 15 συναδέλφους με Email μια εβδομαδιαία έκθεση σε αρχείο Excel, (Sales_Report).
Τα δεδομένα του αρχείου αυτού τα αντιγράφω σε ένα συνολικό αρχείο (Total_Report) .
Τα αρχεία Sales_Report & Total_Report έχουν την ίδια μορφοποίηση.
Θέλω να διαμορφώσω το αρχείο Sales_Report με έναν κώδικα σε VBA ώστε όταν το λαμβάνω με Email , ο κώδικας να καλεί το αρχείο
Total_Report από μια συγκεκριμένη διαδρομή (F:\SALES\Total\Total_Report.xls) και να αντιγράφει τα δεδομένα από την πρώτη ελεύθερη γραμμή και κάτω.
Επειδή υπάρχει ο κίνδυνος οι συνάδελφοι να μπερδευτούν και να μου στείλουν το αρχείο 2 φορές η να μου στείλουν δεδομένα που μου έχουν ξαναστείλει,
θέλω ο κώδικας πριν κάνει την επικόλληση των δεδομένων να κάνει έλεγχο των γραμμών και αν υπάρχουν δεδομένα που περάστηκαν να τα παραλείπει
βγάζοντας ένα σχετικό μήνυμα.
Ο έλεγχος πρέπει να γίνεται σε όλη τη γραμμή από την στήλη A έως τη στήλη Q.
Τα δεδομένα σε όλες τις στήλες εκτός από την B (ΗΜΕΡΟΜΗΝΙΑ) είναι με επικύρωση δεδομένων από λίστα.
Αφού γίνεται η αντιγραφή να σώζεται το αρχείο (Total_Report.xls ) και να κλείνει.
Ξέροντας ότι ζητάω πολλά, αλλά ελπίζοντας στη βοήθειά σας
Σας ευχαριστώ όλους εκ των προτέρων.

Γιώργος

[Tasos]

Γιώργο καλημέρα!
Για να προσθέσεις δεδομένα στο βιβλίο 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 βήματα για να δεις τη λειτουργία του.


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


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


Τάσος