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

Forum (https://www.ms-office.gr/forum/)

- Excel - Ερωτήσεις / Απαντήσεις (https://www.ms-office.gr/forum/excel-erotiseis-apantiseis/)

- - [VBA] Έλεγχος ονόματος ενός φύλλου σε 850 αρχεία Excel! (https://www.ms-office.gr/forum/excel-erotiseis-apantiseis/703-elegxos-onomatos-enos-filloy-se-850-arxeia-excel.html)

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

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

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

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

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

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

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

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

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

Χάρης

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

Κώδικας:

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

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

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

Τάσος

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

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

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

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

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

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

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

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

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