XL 2013 liste onglets visibles

[Lolo4428]

Bonjour
cela fait maintenant quelque temps que je cherche un code VBA
afin de faire une liste de tout mes onglets visibles

le fichier que je développe actuellement
a partir d un onglet "saisie"
et d'un onglet type,
je génère un nouvel onglets

jusque la sa roule lol

par contre sur mon onglet de saisie j'essaie d'inclure un bouton me permettant de créer la liste de tout les onglets "visibles"
or la je n y arrive pas du tout

j'ai trouvais ceci sur le net

Sub NameSheets()
'Updateby Extendoffice
Dim x As Long, y As Long, z As Long
Dim ws As Worksheet
Dim shtCnt As Integer
x = 1
y = 1
z = 1
shtCnt = ThisWorkbook.Sheets.Count
On Error Resume Next
Application.ScreenUpdating = False
Sheets.Add After:=Sheets(Sheets.Count)
For i = 1 To shtCnt
If Sheets(i).Visible = xlSheetHidden Then
Cells(x, 2) = Sheets(i).Name
x = x + 1
End If
If Sheets(i).Visible = xlSheetVisible Then
Cells(y, 1) = Sheets(i).Name
y = y + 1
End If
If Sheets(i).Visible = xlSheetVeryHidden Then
Cells(z, 3) = Sheets(i).Name
z = z + 1
End If
Next i
Application.ScreenUpdating = True
End Sub

sa fonctionne bien meme trop bien

le hic c 'est que sans les petits commentaire sur chaque ligne je ne comprends pas tout

l'idée est de garder que la liste des onglets visibles et de ne pas recréer un onglet mais le faire sur un onglet liste défini exemple l'onglet 1

Cordialement

Laurent

 

[job75]

Bonsoir Lolo4428,

Testez cette macro, à affecter au bouton :

Sub Liste_onglets_visibles()
Dim s As Object, a$(), n
For Each s In Sheets
    If s.Visible = xlSheetVisible Then
        ReDim Preserve a(n) 'base 0
        a(n) = s.Name
        n = n + 1
    End If
Next
'---restitution---
With [A1] '1ère cellule, à adapter
    .Resize(n) = Application.Transpose(a)
    .Offset(n).Resize(Rows.Count - n - .Row + 1).ClearContents 'RAZ en dessous
End With
End Sub

Bonne nuit.

 

[Lolo4428]

Bonsoir Lolo4428,

Testez cette macro, à affecter au bouton :

Sub Liste_onglets_visibles()
Dim s As Object, a$(), n
For Each s In Sheets
    If s.Visible = xlSheetVisible Then
        ReDim Preserve a(n) 'base 0
        a(n) = s.Name
        n = n + 1
    End If
Next
'---restitution---
With [A1] '1ère cellule, à adapter
    .Resize(n) = Application.Transpose(a)
    .Offset(n).Resize(Rows.Count - n - .Row + 1).ClearContents 'RAZ en dessous
End With
End Sub

Bonne nuit.

Merci beaucoup sa fonctionne très bien

une question supplémentaire penses tu qu'il serait possible de transférer le nom de l'onglet en un lien hypertexte
c'est à dire en cliquant dessus on va directement sur la feuille concernée

Encore Merci

 

[job75]

Bonjour Lolo4428,

Sub Liste_onglets_visibles()
Dim dest As Range, w As Worksheet
Set dest = [A1] '1ère cellule de destination, à adapter
Application.ScreenUpdating = False
dest.Resize(Rows.Count - dest.Row + 1).Clear 'RAZ
For Each w In Worksheets
    If w.Visible = xlSheetVisible Then
        dest.Hyperlinks.Add dest, "", "'" & w.Name & "'!A1", TextToDisplay:=w.Name
        Set dest = dest(2)
    End If
Next
End Sub

Dans le lien le nom de la feuille est toujours encadré par des apostrophes même si ce n'est pas nécessaire.

A+

 

[job75]

Avec cette macro le nom de la feuille est encadré par des apostrophes uniquement si nécessaire :

Sub Liste_onglets_visibles()
Dim dest As Range, w As Worksheet, x$
Set dest = [A1] '1ère cellule de destination, à adapter
Application.ScreenUpdating = False
dest.Resize(Rows.Count - dest.Row + 1).Clear 'RAZ
For Each w In Worksheets
    If w.Visible = xlSheetVisible Then
        x = IIf(TypeName(Evaluate(w.Name & "!A1")) = "Range", "", "'")
        ActiveSheet.Hyperlinks.Add dest, "", x & w.Name & x & "!A1", TextToDisplay:=w.Name
        Set dest = dest(2)
    End If
Next
End Sub

 

[job75]

On peut aussi utiliser la fonction LIEN_HYPERTEXTE, entrée en bloc ce sera plus rapide :

Sub Liste_onglets_visibles()
Dim w As Worksheet, x$, a(), n&
Application.ScreenUpdating = False
With [A1] '1ère cellule de destination, à adapter
    .Resize(Rows.Count - .Row + 1).Clear 'RAZ
    For Each w In Worksheets
        If w.Visible = xlSheetVisible Then
            x = IIf(TypeName(Evaluate(w.Name & "!A1")) = "Range", "", "'")
            ReDim Preserve a(n) 'base 0
            a(n) = "=HYPERLINK(""#" & x & w.Name & x & "!A1"",""" & w.Name & """)"
            n = n + 1
        End If
    Next
    .Resize(n) = Application.Transpose(a) 'restitution
End With
End Sub

 

[job75]

Testé avec 1000 feuilles (toutes visibles) :

- macro du post #5 => 0,5 seconde

- macro du post #6 => 0,1 seconde.

 

[Lolo4428]

Merci Beaucoup
Job75