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/3544-dimioyrgia-sygkentrotikoi-pinaka-me-times-apo-kleista-arxeia.html)

Δημιουργία συγκεντρωτικού πίνακα με τιμές από κλειστά αρχεία

Καλησπέρα σας.

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

Όσο για το ερώτημα μου,

Υφίσταται ένας φάκελος με πανομοιότυπα αρχεία Excel όσον αφορά διάταξη και μορφοποίηση, τύπου Φόρμα Συμπλήρωσης Στοιχείων. Τα εν λόγω αρχεία αυξάνονται με τη πάροδο του χρόνου (καινούργιες εγγραφές) . Ο σκοπός μου ήταν να δημιουργήσω ένα πίνακα όπου θα συγκεντρώνει τιμές από συγκεκριμένα κελιά από το κάθε αρχείο. Η θέση των ζητούμενων κελιών είναι ίδια σε όλα τα αρχεία.

"Ψαρεύοντας" έναν κώδικα ο οποίος περίπου εκτελούσε την ενέργεια που ήθελα, πέρασα τις δικές μου παραμέτρους, τον αναπαρήγαγα τόσες φορές όσο και ο αριθμός των κελιών που ήθελα να εμφανίζονται στο συγκεντρωτικό πίνακα, και έδεσα το όλο "μείγμα" σε ένα ωραιότατο command button!!!

Όλα δούλευαν ρολόι μέχρι που έφτασε η στιγμή να αναβαθμιστώ από Office 2003 σε Office 2010.

Σε αυτό το σημείο μου χτύπησε το παράθυρο ο κος Debuger, σκέφτηκα μήπως έπρεπε να αλλάξω τους τύπους αρχείων σε .xlsx, αλλά τελικά η απειρία μου σήκωσε τα χέρια ψηλά και αποφάσισα να απευθυνθώ σε κάποιον πιο έμπειρο.

Επισυνάπτω μία κενή φόρμα και το αρχείο όπου εφαρμόζεται ο κώδικας, επειδή... ας μη γελιόμαστε... ένας κώδικας είναι καλύτερος από χίλιες λέξεις (και ας περιέχει μόνο 5!!!)

Ευχαριστώ εκ των προτέρων για το χρόνο σας και υπόσχομαι δωρεάν μπύρες για 1 χρόνο σε όποιον με βοηθήσει να λύσω αυτή τη σπαζοκεφαλιά!

Καλημέρα
Application.Run "Report.xlsm!Φύλλο1.LoopThruBooks1"
Το αρχείο report έχει επέκταση xlsm, και εδώ γίνεται το ΄σπάσιμο του κώδικα
Θανάσης

Γιαννη το προβλημα σου ειναι σχετικα απλο

αλλαξε τα παρακατω

ΠΡΩΤΟ
Private Sub CommandButton1_Click()

Application.Run "Report.xlsm!Φυλλο1.LoopThruBooks1"

End Sub
και μετα σε ολες της ρουτινες
p = "το path που ειναι τα αρχεια σου "
f = Dir(p & "*.xlsx")

φιλακια περιμενω μπυρες ξερεις που

Αρχικά ευχαριστώ Θανάση και Γιώργο για τις απαντήσεις τους.

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

Βέβαια σε αυτό το σημείο πρέπει να αναφέρω κάτι που διαπίστωσα κάνοντας διάφορα πειράματα.

Αρχικά γύρισα όλα τα αρχεία σε xlsm.
Μετά γύριζα ένα ένα τα αρχεία σε xlsx και ταυτόχρονα έτρεχα τον κώδικα
Αποτέλεσμα να μου εμφανίζει μία μία τις εγγραφές στο συγκεντρωτικό πίνακα.

Και σε αυτό το σημείο βρήκα το ουσιαστικό πρόβλημα. 2 αρχεία είχαν στο όνομα τους απόστροφο (') (με πληκτρολόγιο γυρισμένο στα αγγλικά)!!!

Μόλις έδινα σε κάποιο από αυτά τα 2 αρχεία τύπο xlsx, τα διάβαζε ο κώδικας και σκάλωνε!!!
Οπότε μία μικρή απλή μετονομασία έλυσε το πρόβλημα! :thumbup:

Όπως και να έχει τις μπύρες τις έταξα και είστε ευπρόσδεκτοι.

Τώρα αν θέλετε να τις κερδίσετε με την αξία σας έχω έναν άλλο γρίφο ο οποίος θα αναφερθεί σε σχετικό thread λίαν συντόμως. :dft012:

Χάριν αποσαφήνισης βέβαια θα μπορούσε κάποιος να με διαφωτίσει για ποιο λόγο η απόστροφος επηρέαζε τον κώδικα? Καθαρά ακαδημαϊκό ενδιαφέρον!

Επισυνάπτω και το τελικό αποτέλεσμα

αν δεν απατομε το (') στην VBA ειναι χαρακτηρας που απο εκει και περα οτι υπαρχει τα περνει σαν σχολιο

Καλησπέρα στην παρέα!

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

Βάλε τον παρακάτω κώδικα σε μια κοινή λειτουργική μονάδα (Module) και δοκίμασε:

Κώδικας:

Option Explicit
 

Const strFolderPath = "G:\Juventus Club House\Εκδηλώσεις\Εκδηλώσεις 2014-2015\"

Const WorkSheetName = "Φύλλο1'!"

Const ext = "xlsx"
 

Sub GetValues()
 

    Dim fso As New Scripting.FileSystemObject '

    'Scripting.FileSystemObject: Στο μενού "Tools > References"

    'τσεκάρουμε την αναφορά VB: Microsoft Scripting Runtime
 

    Dim oFolder As Scripting.Folder

    Dim oFile As Scripting.file

    Dim strFile As String

    Dim lngRow As Long
 

    If fso.FolderExists(strFolderPath) Then

        Set oFolder = fso.GetFolder(strFolderPath)

        Application.ScreenUpdating = False

        lngRow = 4

        For Each oFile In oFolder.Files

            If LCase(fso.GetExtensionName(oFile.path)) = ext Then

                strFile = fso.GetFileName(oFile.path)

                Range("A" & lngRow).Value = GetXLValue(strFile, Range("E7"))

                Range("B" & lngRow).Value = GetXLValue(strFile, Range("B3"))

                Range("C" & lngRow).Value = GetXLValue(strFile, Range("B2"))

                Range("D" & lngRow).Value = GetXLValue(strFile, Range("F3"))

                Range("E" & lngRow).Value = GetXLValue(strFile, Range("D12"))

                Range("F" & lngRow).Value = GetXLValue(strFile, Range("B11"))

                Range("G" & lngRow).Value = GetXLValue(strFile, Range("F6"))

                Range("I" & lngRow).Value = GetXLValue(strFile, Range("D8"))

                Range("K" & lngRow).Value = GetXLValue(strFile, Range("B9"))

                Range("L" & lngRow).Value = GetXLValue(strFile, Range("F9"))

                lngRow = lngRow + 1

            End If

        Next

    Else

        MsgBox "Η διαδρομή του φακέλου δεν βρέθηκε!", vbExclamation, "Σφάλμα!"

    End If

    Application.ScreenUpdating = True

End Sub
 

Function GetXLValue(strFilename As String, oCell As Range) As Variant

    Dim strArgs As String

    Dim varTemp As Variant

    strArgs = "'" & strFolderPath & "[" & Replace(strFilename, "'", "''") & _

              "]" & WorkSheetName & oCell.Address(ReferenceStyle:=xlR1C1)
               ' Replace(strFilename, "'", "''")

              ' Διπλασιάζει τυχόν αποστρόφους που υπάρχουν στο όνομα του βιβλίου

              ' ώστε να αναγνωριστούν ως κοινοί χαρακτήρες και όχι ως αναγνωριστικά συμβολοσειράς.

              

    varTemp = ExecuteExcel4Macro(strArgs)
 

    If IsError(varTemp) Then
         'Η παρακάτω γραμμή αυτή μπορεί να ενεργοποιηθεί αν χρειαστεί

        'ώστε να εμφανιστούν ελεγχόμενα τυχόν σφάλματα στα αντίστοιχα κελιά
 

        ' GetXLValue = vbNullString ' ή GetXLValue = "Σφάλμα"

    Else

        GetXLValue = varTemp

    End If

End Function

Ανεβάζω και το συνημμένο παράδειγμα.

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

Τάσος