[VBA] Έλεγχος ονόματος ενός φύλλου σε 850 αρχεία Excel!

[Charis]

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

Το πρόβλημα μου είναι μάλλον δύσκολο...

Θέλω να δημιουργήσω μια λίστα που να περιέχει το όνομα εκείνων των αρχείων που περιέχουν το φύλλο με όνομα "Term_XXE".

Τα αρχεία αυτά βρίσκονται στο φάκελο "H:\DATA" και είναι περίπου 850!!

Θα ήθελα επίσης αν γίνεται να δημιουργήσω Hyperlink για τα αρχεία της λίστας αυτής.

Έχω ήδη δοκιμάσει με VBA να ανοίγω τα αρχεία και να ελέγχω αν υπάρχει το φύλλο "Term_XXE" αλλά είναι αρκετά χρονοβόρο
και επίσης δεν λειτουργεί όταν τα αρχεία είναι κλειδωμένα με διαφορετικό κωδικό για κάθε αρχείο!

Έχετε καμιά ιδέα;

Ευχαριστώ εκ των προτέρων.

Χάρης

[Tasos]

Καλησπέρα σε όλους!
Αγαπητέ Χάρη, αν δεν υπήρχαν τα κλειδωμένα αρχεία που ανέφερες θα σου πρότεινα
τον παρακάτω κώδικα:

Sub CheckSheetInXLFiles_xl4Macro()
    Dim sPath As String, sFile As String, ShName As String, iRow As Long
    sPath = "H:\DATA\"
    iRow = 2
    sFile = Dir(sPath & "*.xls")
    ShName = "Term_XXE"

    With ThisWorkbook
        While sFile <> ""
            If Not sFile = .Name Then
                If Not IsError(ExecuteExcel4Macro( _
                               "'" & sPath & "[" & sFile & "]" & ShName & "'!R1C1")) Then
                    .Sheets(1).Cells(iRow, xlConstant) = sPath & sFile
                    iRow = iRow + 1
                End If
            End If
            sFile = Dir
        Wend
    End With
End Sub

ο οποίος είναι κατά πολύ γρηγορότερος από τον παρακάτω:

Option Explicit

Sub CheckSheetInXLFiles()
    'VBA References: Microsoft Active Data Objects 2.x Library
    '              : Microsoft Ado Ext. 2.x for DDL and Security

    Dim AD_Conn As ADODB.Connection, AD_Catalog As ADOX.Catalog, AD_Table As ADOX.Table
    Dim sPath As String, sFile As String, ShName As String
    Dim LRow As Long, Prov As String, xProps As String
    Dim sConn As String, TableName As String, sh As Worksheet, WBName As String

    Set sh = ThisWorkbook.Worksheets(1)
    sPath = "H:\DATA\"
    sPath = Replace(sPath, "\\", "\")
    ShName = "Term_XXE"
    LRow = 2
    WBName = ThisWorkbook.Name
    sFile = Dir(sPath & "*.xls*")
    On Error Resume Next
    With Application
        .ScreenUpdating = False
        Set AD_Conn = New ADODB.Connection
        Set AD_Catalog = New ADOX.Catalog
        While sFile <> ""
            If Not sFile = WBName Then
                If Mid(sFile, InStrRev(sFile, ".")) = ".xls" Then
                    Prov = "Jet.OLEDB.4.0;"
                    xProps = "Excel 8.0;"
                ElseIf Mid(sFile, InStrRev(sFile, ".")) Like ".xls?" Then
                    Prov = "ACE.OLEDB.12.0;"
                    xProps = """Excel 12.0;HDR=YES"""
                End If
                sConn = "Provider=Microsoft." & Prov & "Data Source=" & _
                        sPath & sFile & ";Extended Properties=" & xProps & ";"
                AD_Conn.Open sConn
                If Err = 0 Then
                    Set AD_Catalog.ActiveConnection = AD_Conn
                    For Each AD_Table In AD_Catalog.Tables
                        TableName = AD_Table.Name
                        If Replace(Replace(TableName, "$", ""), "'", "") = ShName Then
                            sh.Cells(LRow, xlConstant) = sPath & sFile
                            LRow = LRow + 1
                            AD_Conn.Close
                            Exit For
                        End If
                    Next
                End If
                AD_Conn.Close
            End If
            If Err <> 0 Then Err.Clear
            sFile = Dir
        Wend
        .ScreenUpdating = True
    End With
End Sub

Ο παραπάνω κώδικας, λόγω των αντικειμένων που καλεί, μπορεί να ελέγξει για το όνομα των φύλλων ενός αρχείου Excel παρακάμπτοντας τον κωδικό προστασίας.

Και στις δύο περιπτώσεις η αναζήτηση θα γίνει χωρίς να ανοιχτούν τα αρχεία Excel.

Όσο για τα Hyperlink, μπορείς να χρησιμοποιήσεις το συμβάν BeforeDoubleClick() στη λειτουργική μονάδα του φύλλου που θα περιέχει τη λίστα με τα ονόματα των αρχείων:

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If Not Intersect(Target, Range("A:A")) Is Nothing Then
        Cancel = True
        If VBA.Dir(Target.Text, 0) <> "" Then Workbooks.Open Target.Text
    End If
End Sub

Ελπίζω να βοήθησα!

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

Τάσος

[Charis]

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

Τελικά, δεν υπάρχει περίπτωση σ αυτό το φόρουμ να μείνει κάποια ερώτηση αναπάντητη!

Τάσο, μου έλυσες τα χέρια!

Χρησιμοποίησα και τους 2 κώδικες που μου υπέδειξες.

Τον πρώτο CheckSheetInXLFiles_xl4Macro() για τα μη προστατευμένα αρχεία
(από το όνομα τους μπόρεσα να τα διαχωρήσω) και τον δεύτερο CheckSheetInXLFiles() για τα προστατευμένα!

Χρησιμοποίησα και το Worksheet_BeforeDoubleClick() κι έτσι με διπλό κλικ στο κελί μου ανοίγει το αντίστοιχο αρχείο.

Να είσαι καλά!

Σε υπέρευχαριστώ!

Με εκτίμησηΧάρης