Discussion :

[sagull]

Bonjour,
J'ai besoin d'importer la liste des noms de feuilles de mon classeur fermé dans des cellules de mon classeur ouvert et pour cela j'ai fait ceci (je n'ai rien inventé...)

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
 
1.Private Sub CommandButton1_Click()
2.
3.Dim XlConnect As Object, XlCatalog As Object
4. Dim Fichier As String, Resultat As String
5. Dim Feuille As Object
6. Dim objCell As Range
7.
8.Fichier = "h:\monfichierferme.xls"
9.
10.Set XlConnect = CreateObject("ADODB.Connection" )
11. Set XlCatalog = CreateObject("ADOX.Catalog" )
12.
13.XlConnect.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Fichier & _
14. ";Extended Properties=Excel 8.0;"
15. Set XlCatalog.ActiveConnection = XlConnect
16.
17.Cells(1, 1).Select
18.
19.'je ne récupére que les noms qui se terminent par "$"
20.
21.For Each Feuille In XlCatalog.Tables
22. If UCase(Right(Feuille.Name, 1)) = "$" Then
23. ActiveCell = Feuille.Name
24.
25.
26.'et suprime le "$"
27.
28.For Each objCell In Selection
29.     If Right(objCell.Value, 1) = "$" Then
30.         objCell.Value = Left(objCell.Value, Len(objCell.Value) - 1)
31.     End If
32. Next objCell
33.
34.ActiveCell.Offset(1, 0).Select
35.
36.End If
37.
38.Next
39.
40.End Sub

ce code fonctionne parfaitement sous excel 2003 ou 2010 mais bug sous 2000 avec un message d'erreur:
"projet ou bibliothéque introuvable" et surligne de cette façon la ligne

If UCase(Right(Feuille.Name, 1)) = "$" Then

que me faut-il modifier pour que cela fonctionne svp ?
s' agit-il de Microsoft office 11.0 object library coché d'un coté et Microsoft office 9.0 object library de l'autre dans les références ?
puis-je contourner le pobléme ?

Un grand merci pour vos réponses

[Theze]

Bonjour,

Et en supprimant directement le dollar à la récupération du nom des feuille ? Adapter dans la proc "Test" le chemin puis lancer, le résultat sera en colonne A :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
 
Public Function FeuillesExcel(Cat As Object) As String()
 
    Dim tbl As Object
    Dim Tablo() As String
    Dim I As Integer
 
    'crée l'objet table
    Set tbl = CreateObject("ADOX.Table")
 
    'passe les feuilles en revue et récupère leurs nom sans le dollar
    'dans un tableau
    For Each tbl In Cat.Tables
 
        I = I + 1
        ReDim Preserve Tablo(1 To I)
        Tablo(I) = Replace(tbl.Name, "$", "")
 
    Next
 
    'passe à la fonction
    FeuillesExcel = Tablo
 
    Set tbl = Nothing
 
End Function
 
Private Sub Test()
 
    Dim Cat As Object
    Dim Fichier As String
    Dim T() As String
    Dim I As Integer
 
    'crée l'objet catalogue
    Set Cat = CreateObject("ADOX.Catalog")
 
    'défini le chemin du fichier
    Fichier = "D:\Classeur2.xls"
 
    'crée la connexion au catalogue
    Cat.ActiveConnection = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & _
                           Fichier & _
                           ";Extended Properties=""Excel 8.0;HDR=NO;IMEX=2;"""
 
    'récupère les noms des feuilles
    T = FeuillesExcel(Cat)
 
    'et les inscrit en colonne A
    For I = 1 To UBound(T)
 
        Cells(I, 1) = T(I)
 
    Next I
 
End Sub

Hervé.

[sagull]

Bonsoir,
Merci pour ton code Hervé, je le garde précieusement car même si, grace au forum, j' avance à grands pas, je n'en ai pas encore à l'objectif.
ci dessous, un exemple de ce que me renvoie l'importation des noms de feuilles brut (sans reprise des $ et autres ).
en rouge, les feuilles réellement existantes et le reste est à suprimer. ton code me renvoie toute la liste (sans $ certe)
ceci dit, on avance mais il faut que je teste demain sous 2000

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25

FEUILLE7Z_8D8F0B13_08B5_4D3D_BC9C_C6772D70C41C_#wvu#Rows
FEUILLE7Zone_d_impressio
Feuil1$
Feuil2$
FEUILLE4$FEUILLE4$Z_61509ED6_F05E_4D05_BB8D_44D53319CB42_#wvu#PrintArea
FEUILLE4$Z_7664CF95_4C76_4B49_BE51_49C2D8BF17AE_#wvu#PrintArea
FEUILLE4$Z_8D8F0B13_08B5_4D3D_BC9C_C6772D70C41C_#wvu#PrintArea
FEUILLE5$
FEUILLE5$Z_61509ED6_F05E_4D05_BB8D_44D53319CB42_#wvu#PrintArea
FEUILLE5$Z_61509ED6_F05E_4D05_BB8D_44D53319CB42_#wvu#Rows
FEUILLE5$Z_7664CF95_4C76_4B49_BE51_49C2D8BF17AE_#wvu#PrintArea
FEUILLE5$Z_7664CF95_4C76_4B49_BE51_49C2D8BF17AE_#wvu#Rows
FEUILLE5$Z_8D8F0B13_08B5_4D3D_BC9C_C6772D70C41C_#wvu#PrintArea
FEUILLE5$Z_8D8F0B13_08B5_4D3D_BC9C_C6772D70C41C_#wvu#Rows
FEUILLE5$Zone_d_impressio
FEUILLE6$
FEUILLE6$Z_61509ED6_F05E_4D05_BB8D_44D53319CB42_#wvu#PrintArea
FEUILLE6$Z_61509ED6_F05E_4D05_BB8D_44D53319CB42_#wvu#Rows
FEUILLE6$Z_7664CF95_4C76_4B49_BE51_49C2D8BF17AE_#wvu#PrintArea
FEUILLE6$Z_7664CF95_4C76_4B49_BE51_49C2D8BF17AE_#wvu#Rows
FEUILLE6$Z_8D8F0B13_08B5_4D3D_BC9C_C6772D70C41C_#wvu#PrintArea
FEUILLE6$Z_8D8F0B13_08B5_4D3D_BC9C_C6772D70C41C_#wvu#Rows
FEUILLE6$Zone_d_impressio

un autre exeemple ci dessous de ce qui est renvoyé avec un autre fichier sous 2008 et on trouve des " ' " aprés les " $ " cette fois, ça complique

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
 FEUILLE5 compteurs$'Zone_d_impressio
FEUILLE4$'
FEUILLE4$'_
FEUILLE4$'Zone_d_impressio
FEUILLE5$
FEUILLE5$Zone_d_impressio
FEUILLE6$'Zone_d_impressio
FEUILLE7$'
FEUILLE7$'Zone_d_impressio
FEUILLE3i compteurs$'Zone_d_impressio
feuille3$'
feuille2$'Zone_d_impressio
FEUILLE8 compteurs  $'Zone_d_impressio
FEUILLE8$'
FEUILLE8$'Zone_d_impressio
FEUILLE9$'
FEUILLE9$'Zone_d_impressio
MFC$
FEUILLE110$'
FEUILLE110$'_
FEUILLE110$'Impression_des_t
FEUILLE110$'Zone_d_impressio
FEUILLE13$'
FEUILLE13$'Zone_d_impressio
FEUILLE12$'
FEUILLE12$'Zone_d_impressio
FEUILLE6 compteurs$'Zone_d_impressio
FEUILLE11 $'
FEUILLE11 $'Zone_d_impressio
feuille2$'Zone_d_impressio

il va falloir que je gére toute les éventualité mais il faut d'abord que le code me renvoie les valeurs, je teste demain sous 2000 et reviens rendre compte

Merci et bonne soirée

[kiki29]

Salut, fonctionne ici de 97 à 2007, à adapter à ton contexte

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
Option Explicit
 
Dim Ar() As String
 
Sub Tst()
Dim sFichier As String
Dim i As Long
 
    sFichier = ThisWorkbook.Path & "\" & "Test.xls"
    ListeNomFeuilles sFichier
 
    '   Ar() contient le nom des feuilles dans l'ordre ALPHABETIQUE
    '   et non dans l'ordre des positions dans le classeur testé
 
    Application.ScreenUpdating = False
    Feuil1.Columns("A:A").ClearContents
    For i = 1 To UBound(Ar)
        Feuil1.Cells(i, 1) = Ar(i)
    Next i
    Application.ScreenUpdating = True
End Sub
 
Private Sub ListeNomFeuilles(sNomFichier As String)
Dim Conn As Object
Dim Cat As Object
Dim Feuille As Object
Dim i As Long
 
    Erase Ar
    Set Conn = CreateObject("ADODB.Connection")
    Set Cat = CreateObject("ADOX.Catalog")
 
    Conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=" & sNomFichier & ";Extended Properties=Excel 8.0;"
 
    Set Cat.ActiveConnection = Conn
 
    For Each Feuille In Cat.Tables
        Select Case Right$(Feuille.Name, 1)
            Case "$"
                i = i + 1
                ReDim Preserve Ar(i)
                Ar(i) = Left$(Feuille.Name, Len(Feuille.Name) - 1)
            Case "'"
                ' Nom de feuille comportant des espaces
                i = i + 1
                ReDim Preserve Ar(i)
                Ar(i) = Mid$(Feuille.Name, 2, Len(Feuille.Name) - 3)
        End Select
    Next Feuille
 
    Conn.Close
    Set Conn = Nothing
    Set Cat = Nothing
End Sub

[sagull]

Bonjour,
sous 2010, ton code bloque sur "ReDim Preserve Ar" avec une alerte "ReDim incorrect" j'ai regardé dans outils/référenes mais pas de MANQUANT.

de mon coté je n'ai pas encore testé sur les autres versions, surement dans la journée

Merci kiki29

[sagull]

Bonjour,
Merci à vous, au final je suis parvenu, avec votre aide, à ce résultat qui fonctionne dans tous les cas de figure.
reste un cas particulier à gérer qui est le suivant:
quand je lance ma macro fichier fermé tout est ok et j'ai bien la liste des feuilles visibles avec leur nom propre par contre si d'aventure le fichier se trouve être ouvert alors viennent aussi s'ajouter les feuilles cachées(en hidden), ce que je ne souhaite pas.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
 
Private Sub CommandButton1_Click()
Dim XlConnect As Object, XlCatalog As Object
Dim Fichier As String, Resultat As String
Dim Feuille As Object
 
 
Fichier = "h:\monfichierferme.xls"
 
 
Set XlConnect = CreateObject("ADODB.Connection")
Set XlCatalog = CreateObject("ADOX.Catalog")
 
XlConnect.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Fichier & _
";Extended Properties=Excel 8.0;"
Set XlCatalog.ActiveConnection = XlConnect
 
Cells(1, 1).Select
 
'je teste si le nom de chaque feuille se termine par $ ou par $' et si oui l'importe dans ma ellule
For Each Feuille In XlCatalog.Tables
If UCase(Right(Feuille.Name, 1)) = "$" Or UCase(Right(Feuille.Name, 2)) = "$'" Then
ActiveCell.Value = nom
ActiveCell = Feuille.Name
 
'je reprend chaque valeur et si elle se termine par $ je suprime 1 caractére à la fin
'si elle se termine par $' je suprime 2 caractéres à la fin
Dim objCell As Range
 
For Each objCell In Selection
 
    If Right(objCell.Value, 1) = "$" Then
        objCell.Value = Left(objCell.Value, Len(objCell.Value) - 1)
    End If
    If Right(objCell.Value, 2) = "$'" Then
        objCell.Value = Left(objCell.Value, Len(objCell.Value) - 2)
    End If
 
Next objCell
 
ActiveCell.Offset(1, 0).Select
 
End If
 
Next
 
End Sub