[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

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

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

Τάσος