XL 2013 liste onglets visibles

Lolo4428

XLDnaute Nouveau
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

XLDnaute Barbatruc
Bonsoir Lolo4428,

Testez cette macro, à affecter au bouton :
VB:
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

XLDnaute Nouveau
Bonsoir Lolo4428,

Testez cette macro, à affecter au bouton :
VB:
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

XLDnaute Barbatruc
Bonjour Lolo4428,
VB:
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

XLDnaute Barbatruc
Avec cette macro le nom de la feuille est encadré par des apostrophes uniquement si nécessaire :
VB:
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

XLDnaute Barbatruc
On peut aussi utiliser la fonction LIEN_HYPERTEXTE, entrée en bloc ce sera plus rapide :
VB:
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
 

Discussions similaires

Statistiques des forums

Discussions
311 720
Messages
2 081 902
Membres
101 834
dernier inscrit
Jeremy06510