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

[johgian]

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

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

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

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

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

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

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

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

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

[Thanosp]

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

[asterix]

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

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

ΠΡΩΤΟ
Private Sub CommandButton1_Click()

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

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

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

[johgian]

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

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

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

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

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

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

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

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

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

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

[asterix]

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

[Tasos]

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

Γιάννη, φρόντισε να αποφεύγεις τα συγχωνευμένα κελιά ειδικά όταν χρησιμοποιείς 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

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

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

Τάσος