XL 2016 VBA - Trouver les feuilles d'un classeur fermé

[Dudu2]

Bonjour,

J'ai bien une fonction pour trouver les valeurs d'une feuille donnée d'un classeur fermé (fichier joint) mais je n'ai rien pour trouver les noms des feuilles de ce classeur fermé.

Merci par avance.

 

[Dudu2]

Bonjour,
Petit update sur les codes de récupération DB des noms de feuilles sur un classeur donné peut-être particulier (en quoi ?)

Avec la méthode @dysorthographie: (une supplémentaire _xlnm)

Avec la méthode @patricktoulon: (il en manque)

Je vais essayer de simplifier le fichier et le poster.

 

[patricktoulon]

Bonjour à tous
comme l'aurent m'a beaucoup plus avec son idée originale
je l'ai refaite 100% vba sans powershell;;

'********************************************************
'collection fonctions particulières et originales disk Rac 3
'liste des feuilles dans un classeur fermé sur une idée de @laurent950
'auteur :patricktoulon
'version patricktoulon 100% VBA
'********************************************************

Option Explicit

Sub testFX()
    Dim ListSheet, FilePath$
    'adapter le chemin ici ou injecter un dialog getopenfilename
    FilePath$ = "C:\Users\patricktoulon\Desktop\tototo.xlsx"
    ListSheet = ListSheetOnClosedFileXML(FilePath)
    If UBound(ListSheet) > 0 Then MsgBox Join(ListSheet, vbCrLf)
End Sub

Function ListSheetOnClosedFileXML(lPath As String)
    Dim Archiveur, fichierZiP$, fichierxml$, xDoc As Object, noeud, TbL(), A&, FwK
    
    'les chemins de fichiers
    fichierZiP = Replace(lPath, ".xlsx", ".zip")
    fichierxml = Mid(lPath, 1, InStrRev(lPath, "\")) & "workbook.xml"
    
    'on les supprimes si ils existent
    If Dir(fichierZiP) <> "" Then Kill fichierZiP
    If Dir(fichierxml) <> "" Then Kill fichierxml
    
    'on copie le fichier Excel(xlsx , xlsm , xlt , xlb) en format zip
    FileCopy lPath, fichierZiP
    
    'on ouvre un object shell.application
    Set Archiveur = CreateObject("Shell.Application")
    'on sort en accès direct le fichier  voulu  en l'occurrence ici le workbook.xml qui se trouve dans
    'fichierZiP & "\xl\workbook.xml"
    With Archiveur
        Set FwK = .Namespace(fichierZiP & "\xl\").Items.Item("workbook.xml")
        If FwK Is Nothing Then 'si le workbook.xml n'est pas trouvé(fichier eventuellement corrompu)
            'on  supprime zip et xml on en a plus besoin
            If Dir(fichierZiP) <> "" Then Kill fichierZiP
            If Dir(fichierxml) <> "" Then Kill fichierxml
            ListSheetOnClosedFileXML = TbL
        End If
        'copie du fichier dans la destination
        .Namespace(ThisWorkbook.Path).copyhere FwK.Path
    End With
    
    ' Charger le XML
    Set xDoc = CreateObject("MSXML2.DOMDocument.6.0")
    xDoc.async = False
    xDoc.Load fichierxml
   ' Ajouter espace de noms pour les feuilles
    xDoc.SetProperty "SelectionNamespaces", "xmlns:ss='http://schemas.openxmlformats.org/spreadsheetml/2006/main'"
    ' Parcourir les feuilles en mode Xpath
    For Each noeud In xDoc.SelectNodes("//ss:sheet")
        A = A + 1: ReDim Preserve TbL(1 To A)
        TbL(A) = noeud.Attributes.getNamedItem("name").Text
    Next
    
    'on  supprime zip et xml on en a plus besoin
    If Dir(fichierZiP) <> "" Then Kill fichierZiP
    If Dir(fichierxml) <> "" Then Kill fichierxml
    
    ListSheetOnClosedFileXML = TbL
End Function

 

[patricktoulon]

Bonjour @Dudu2
je ne sais pas ce que tu fait mais ma fonction ne rate aucune feuille
je suppose que tu essaie de mélanger code de robert et le mien par exemple
mais c'est pas une bonne idée
si tu m'en dit plus ,je pourrais peut être t'apporter des réponses

 

[Dudu2]

@patricktoulon,

je ne sais pas ce que tu fait mais ma fonction ne rate aucune feuille

Comment peux-tu en être si sûr ? Le doute est toujours utile, surtout si c'est @Dudu2 qui te met l'embrouille

.

Le mystère est résolu...

Méthode @dysorthographie:
Quand y a du filtre sur une feuille, ça retourne une ou plusieurs (?) valeurs <feuille>_xlnm#_FilterDatabase ou bizarrement <feuille> n'est pas la feuille où se trouve le filtre. C'est pas grave, ça se repère facilement.

Méthode @patricktoulon:
Quand le nom de la feuille contient une valeur numérique elle n'apparait pas.

2 fichiers fournis:
- DB_Tables 2 méthodes.xlsm (Macro pour tester)
- Test Case #4.xlsx (classeur de test)

 

[patricktoulon]

re
ben je corrige pas de soucis
je reviens je fini de l'autre coté avec mes minis calendrier
a tu testé la version xml 100% vba ?

 

[Dudu2]

a tu testé la version xml 100% vba

Non je ne l'ai pas testée mais je suis sûr que ça roule.
Par contre, je suis pas trop adepte de la manip, certes très originale et maline mais je trouve un peu "lourde".

 

[patricktoulon]

re
a ben la ou ado pleure misère pour un rien un espace un nombre et autres raisons que tu as pu évoquer
la version xml elle fait que nenni de tout ça 😉

 

[Dudu2]

Oui, je vais la garder de toutes façons comme une 3ème option, rien ne se perd.

 

[patricktoulon]

corrigé pour ado

Option Explicit
Sub test()
    Dim ListSheet, FilePath$
    'adapter le chemin ici ou injecter un dialog getopenfilename
    FilePath$ = "C:\Users\patricktoulon\Desktop\tototo.xlsx"
    ListSheet = ListSheetOnClosedFile(FilePath)
    If UBound(ListSheet) > 0 Then
        MsgBox Join(ListSheet, vbCrLf)
    Else
        MsgBox "La connection au classeur n'a pas pu lister les feuille du classeur"
    End If
End Sub
Function ListSheetOnClosedFile(lPath As String)
    'patricktoulon collection Ado
    Dim Connection As Object, recordST As Object, TbL(), A&
    Set Connection = CreateObject("ADODB.Connection") ' Créer connexion ADO
    ' Ouvrir connexion (type de connection pour les version superieures a 2003/2007 et +)
    Connection.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & "Data Source=" & lPath & ";" & "Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
    Set recordST = Connection.OpenSchema(20) ' Récupérer la liste des feuilles ' 20 = adSchemaTables
    Do Until recordST.EOF
        'Debug.Print recordST!TABLE_NAME
        If recordST!TABLE_NAME Like "*$*" Then
            A = A + 1
            ReDim Preserve TbL(1 To A)
            TbL(A) = Replace(Replace(recordST!TABLE_NAME, "$", ""), "'", "")
        End If
        recordST.MoveNext
    Loop
    recordST.Close: Connection.Close: Set recordST = Nothing: Set Connection = Nothing
    If A = 0 Then
        ListSheetOnClosedFile = Array() ' on met un tableau vide pour eviter l'erreur dans la sub appelante
    Else
        ListSheetOnClosedFile = TbL
    End If
End Function

j'ai bien les feuilles avec un nombre comme nom et les nom composés

il y a un seul bémol par rapport a la xml c'est qu'il ne sont pas dans l'ordre ni d'ajout ni de modif
tandis que la xml ils sont dans l'ordre

 

[Dudu2]

Ok, à noter que ton code retourne aussi l'extra qu'il faut éliminer.

    Const ExtraWorksheetName = "_xlnm#_FilterDatabase"
    
    If Not Right(RecordSet!TABLE_NAME, Len(ExtraWorksheetName)) = ExtraWorksheetName Then

 

[patricktoulon]

je ne sais pas avec quel code tu obtiens ça mais moi j'ai pas ça peut être devrions nous essayer sur le même fichier analysé

 

[Dudu2]

Mets un filtre sur ton fichier et tu l'auras.

 

[patricktoulon]

ok je vais tester

edit:
avec un filtre actif dans un tableau structuré ca le fait pas
avec un filtre sur range ca le fait (ça fait des doublons en fait )
donc pour le ado:

Option Explicit
Sub test()
    Dim ListSheet, FilePath$
    'adapter le chemin ici ou injecter un dialog getopenfilename
    FilePath$ = "C:\Users\patricktoulon\Desktop\tototo.xlsx"
    ListSheet = ListSheetOnClosedFile(FilePath)
    If UBound(ListSheet) > 0 Then
        MsgBox Join(ListSheet, vbCrLf)
    Else
        MsgBox "La connection au classeur n'a pas pu lister les feuille du classeur"
    End If
End Sub
Function ListSheetOnClosedFile(lPath As String)
    'patricktoulon collection Ado
    Dim Connection As Object, recordST As Object, TbL(), A&
    Set Connection = CreateObject("ADODB.Connection") ' Créer connexion ADO
    ' Ouvrir connexion (type de connection pour les version superieures a 2003/2007 et +)
    Connection.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & "Data Source=" & lPath & ";" & "Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
    Set recordST = Connection.OpenSchema(20) ' Récupérer la liste des feuilles ' 20 = adSchemaTables
    Do Until recordST.EOF
        Debug.Print recordST!TABLE_NAME
        If InStr(recordST!TABLE_NAME, "xlnm#_FilterDatabase") = 0 Then
            If recordST!TABLE_NAME Like "*$*" Then
                A = A + 1
                ReDim Preserve TbL(1 To A)
                TbL(A) = Replace(Replace(Replace(recordST!TABLE_NAME, "$", ""), "'", ""), "_xlnm#_FilterDatabase", "")
            End If
        End If
        recordST.MoveNext
    Loop
    recordST.Close: Connection.Close: Set recordST = Nothing: Set Connection = Nothing
    If A = 0 Then
        ListSheetOnClosedFile = Array() ' on met un tableau vide pour eviter l'erreur dans la sub appelante
    Else
        ListSheetOnClosedFile = TbL
    End If
End Function

pour le xml on change rien là encore il n'a que faire
par contre on peut garantir l'ordre identique

'********************************************************
'collection fonctions particulière et originales disk Rac 3
'liste des feuilles dans un classeur fermé sur une idée de @laurent950
'auteur :patricktoulon
'version patricktoulon 100% VBA
'********************************************************

Option Explicit

Sub testFX()
    Dim ListSheet, FilePath$
    'adapter le chemin ici ou injecter un dialog getopenfilename
    FilePath$ = "C:\Users\patricktoulon\Desktop\tototo.xlsx"
    ListSheet = ListSheetOnClosedFileXML(FilePath)
    MsgBox Join(ListSheet, vbCrLf)
End Sub
Function ListSheetOnClosedFileXML(lPath As String)
    Dim Archiveur, fichierZiP$, fichierxml$, xDoc As Object, noeud, TbL(), A&, X&
    ReDim Preserve TbL(1 To 300)
    'les chemins de fichiers
    fichierZiP = Left(lPath, InStrRev(lPath, ".")) & "zip"
    fichierxml = Mid(lPath, 1, InStrRev(lPath, "\")) & "workbook.xml"
   
    'on les supprimes si ils existent
    If Dir(fichierZiP) <> "" Then Kill fichierZiP
    If Dir(fichierxml) <> "" Then Kill fichierxml
   
    'on copie le fichier Excel(xlsx , xlsm , xlt , xlb) en format zip
    FileCopy lPath, fichierZiP
   
   
    'on ouvre un object shell.application
    Set Archiveur = CreateObject("Shell.Application")
    DoEvents
   
    'on sort en accès direct le fichier  voulu  en l'occurrence ici le workbook.xml qui se trouve dans
    'fichierZiP & "\xl\workbook.xml"
    With Archiveur
        .Namespace(ThisWorkbook.Path).copyhere .Namespace(fichierZiP & "\xl\").Items.Item("workbook.xml")
    End With
   
    ' Charger le XML
    Set xDoc = CreateObject("MSXML2.DOMDocument.6.0")
    xDoc.async = False
    xDoc.Load fichierxml
   
    ' Ajouter espace de noms pour les feuilles
    xDoc.SetProperty "SelectionNamespaces", "xmlns:ss='http://schemas.openxmlformats.org/spreadsheetml/2006/main'"
   
    ' Parcourir les feuilles en mode Xpath
    For Each noeud In xDoc.SelectNodes("//ss:sheet")
        A = noeud.getattribute("sheetId")
        TbL(A) = noeud.Attributes.getNamedItem("name").Text
        If A > X Then X = A
    Next
    ReDim Preserve TbL(1 To X)
    'on  supprime zip et xml on en a plus besoin
    If Dir(fichierZiP) <> "" Then Kill fichierZiP
    If Dir(fichierxml) <> "" Then Kill fichierxml
   
    ListSheetOnClosedFileXML = TbL
End Function

 

[Dudu2]

J'arrive pas à faire fonctionner ton code ZIP.

Déjà j'ai ça:

Ensuite j'ai ça:

Ci-joint mon fichier de test.

 

[patricktoulon]

a hh:!! un fichier n'est pas supprimé là
soit le zip soit le xml
vérifie avec un point d'arrêt
on fait peut être face a un soucis d'autorisation sur le dossier du thisworkbook peut être va t il falloir remettre environ("Temp")

edit :je viens de tester ton classeur1.xlsx et chez moi les deux methode fonctionnent