Lister les onglets d'une feuille avec liens hypertexte

Le 06/04/2022 à 11:46

Bonjour,

J'ai créé ce code pour lister tous les onglets qui se trouve après l'onglet "onglet" et les afficher sur l'onglet "sommaire" avec liens hypertext.

Pour le coup tout fonctionne bien.

Seulement, dès qu'il y a beaucoup d'onglets, cela met beaucoup de temps pour le traitement.

Quelqu'un à une idée? (J'ai mis le fichier en PJ)

Merci d'avance

Private Sub Worksheet_Activate()
58sommaire.zip (251.99 Ko)
    'effacement des données de la colonne A et rajout d'un lien hypertexte pour chaque onglet
    [a14:a3000].ClearContents
    Dim num As Long
    num = Sheets("onglet").Index + 1
    For i = num To Sheets.Count
    nf = Sheets(i).Name
    ActiveSheet.Hyperlinks.Add Anchor:=Cells(i + 4, 1), Address:="", SubAddress:="'" & _
    nf & "'" & "!g13", TextToDisplay:=nf

    Next i

End Sub
Le 06/04/2022 à 11:51

Bonjour,

Pour considérablement augmenter la vitesse d'exécution d'un programme ajoutez en début de code ces lignes:

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Puis en fin de code:

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

A+

Le 06/04/2022 à 13:21

Merci beaucoup Gabin37, cela marche a merveille!

Le 06/04/2022 à 13:30

Pouvez-vous également m'aider sur ce même fichier, avec le même code, pour :

- si un onglet est créé ou supprimer, rajouter ou supprimer la ou les lignes dans le tableau de l'onglet "sommaire"?

je vous joint le fichier en PJ.

22sommaire-avec-tableau.xlsm (49.04 Ko)

Merci d'avance

Le 06/04/2022 à 13:54

Re,

Pour ne pas s'embêter à manipuler le tableau, je vous propose de supprimer totalement les lignes du tableau au lieu de simplement supprimer le contenu.

Ensuite le tableau s'incrémentera automatiquement.

Donc remplacer la ligne:

[a14:a3000].ClearContents

Par cette ligne de code:

Rows("14:3000").Delete

A tester si cela vous conviens.

A+

Le 06/04/2022 à 14:17

Oui en effet ça fonctionne bien, seulement le tableau n'a qu'une seule ligne après!

Il faudrait que le tableau comporte le nombre de ligne par rapport au nombre d'onglet listé.

Le 06/04/2022 à 14:28

Il faudrait que le tableau comporte le nombre de ligne par rapport au nombre d'onglet listé.

Ah ? Chez moi ca fonctionne...

Le tableau s'agrandit automatiquement lorsque la dernière ligne est complétée

image
Le 06/04/2022 à 15:11

Ben avec Excel pro plus 2021 ça ne rajoute pas de ligne dans le tableau, ça garde que le titre et la 1ére ligne !

Une idée?

Le 06/04/2022 à 15:18

Re,

Ben avec Excel pro plus 2021 ça ne rajoute pas de ligne dans le tableau

Je ne savais pas désolé ! Testez en ajoutant cette ligne juste après la boucle i

ActiveSheet.ListObjects("Tableau1").Resize Range("$A$13:$B$" & Sheets.Count - num + 14)

A+

Le 06/04/2022 à 16:28

Super tout fonctionne a merveille, merci beaucoup!

Le 08/04/2022 à 17:36

Je viens de faire le test avec 417 onglets remplie de calcul par onglet et àa prend encore pas mal de temps de calcul!

Il y a t-il une solution pour accélérer ce traitement?

pour rappel du code :

Private Sub Worksheet_Activate()

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

    'effacement des données de la colonne A et rajout d'un lien hypertexte pour chaque onglet
    Rows("14:3000").Delete
    Dim num As Integer
    num = Sheets("vierge").Index + 0
    For i = num To Sheets.Count
      nf = Sheets(i).Name
      ActiveSheet.Hyperlinks.Add Anchor:=Cells(i + 5, 2), Address:="", SubAddress:="'" & _
         nf & "'" & "!g11", TextToDisplay:=nf

    Next i

    'pour gérer le tableau changer valeur colonne
    ActiveSheet.ListObjects("Tableau_chargé_affaire").Resize Range("$A$13:$h$" & Sheets.Count - num + 14)

    Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub
Le 11/04/2022 à 09:34

Bonjour David,

Au vu du code je suis surpris que cela prenne du temps.. Il me semble déjà bien optimisé.

Pour 417 Onglets on est sur combien de temps d'exécution environ ?

Je sèche, peut-être que quelqu'un d'autre saura apporter une brillante idée..

Slts,

Le 11/04/2022 à 09:50

Bonjour Gabin,

il faut environ 30 secondes pour faire le calcul!

j'ai trouver un code qui le fait pratiquement instantanément, mais dès que je met le code pour l'activer dans un tableau sa prend 30 secondes environs de calcul.

Une idées?

Private Sub Worksheet_Activate()
Dim ws As Worksheet, i As Integer

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

    i = 14
        Sheets("chargé d'affaire").Columns("A:B").ClearContents
            For Each ws In Application.Worksheets
               If ws.Name <> "chargé d'affaire" And ws.Name <> "Fiche type" Then
                    'Sheets("RECAP").Range("B" & i) = ws.Name
                    ActiveSheet.Hyperlinks.Add Anchor:=Range("B" & i), Address:="", SubAddress:= _
                    "'" & ws.Name & "'!A1", TextToDisplay:=ws.Name
                    i = i + 4
               End If
            Next ws

        Sheets("chargé d'affaire").Columns("B:C").EntireColumn.AutoFit

Application.Calculation = xlCalculationAutomaticCalculate

Calculate
Application.ScreenUpdating = True

End Sub

code pour gérer le tableau

           ' ActiveSheet.ListObjects("Tableau_charge_affaire").Resize Range("$b$14:$c$" & Sheets.Count - num + 14)

Merci pour vos réponses

Le 11/04/2022 à 13:06

Re,

Mets un stop (Clique dans la marge grise) comme sur la photo ci-dessous et exécute le code en activant l'onglet.

Si le code s'arrête immédiatement c'est que c'est bien la ligne de code qui gère le tableau qui ralenti le code.

A+

image
Le 27/06/2022 à 08:45

Bonjour,

Désoler de répondre tardivement.

J'ai travailler sur mon code pour lister les onglets après l'onglet "CR n°" mais j'ai un code erreur éxécution n°13 qui s'affiche sur "nf = Sheets(i).Name"

Quelqu'un pourrait-il m'aider SVP?

Merci d'avance

Option Explicit

Private Sub Worksheet_Activate()

'desactive protection
    Dim f As Worksheet
    Set f = ActiveSheet
    f.Protect Password:="", UserInterfaceOnly:=True

'active calcul manuel
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Range("t11:t100").Select
    Selection.ClearContents

Dim i As Integer
Dim nf As Worksheet

    Dim num As Integer
    num = Sheets("CR n°").Index + 1
    For i = num To Sheets.Count
      nf = Sheets(i).Name
      ActiveSheet.Hyperlinks.Add Anchor:=Cells(i + 4, 20), Address:="", SubAddress:="'" & _
         nf & "'" & "!A1", TextToDisplay:=nf

    Next i

Sheets("sommaire").Activate

        Range("T8:T100").Select
    With Selection.Font
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
    End With
    Selection.Font.Underline = xlUnderlineStyleNone
    Selection.Font.Italic = False
    Selection.Font.Bold = True
    Selection.Font.Size = 18
    With Selection.Font
        .Name = "AvantGarde S"
        .Size = 18
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Underline = xlUnderlineStyleNone
        .Shadow = False
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With

    Range("t11").Select

    'active calcul automatique
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

End Sub
Le 27/06/2022 à 09:18

Bonjour david,

Peut - être vaut-il mieux créer un nouveau sujet si le problème diffère du premier.

Tu définis la variable nf en temps que "Worksheet" et tu essaye de lui donner du texte: sheets.Name représente le nom de l'onglet au format texte.

Essayes comme cela:

Set nf = Sheets(i)

A+

Le 27/06/2022 à 10:11

Gabin,

Merci pour ta réponse mais je ne comprend pas la modification.

Il faut changer la variable "Dim nf As worksheet" avec quoi?

il faut changer le code "nf = Sheets(i).Name" par "Set nf = Sheets(i)"?

Merci pour ton retour

Le 27/06/2022 à 10:37

Re,

il faut changer le code "nf = Sheets(i).Name" par "Set nf = Sheets(i)"?

Oui c'est tout normalement, a tester

Le 27/06/2022 à 11:26

Je suis désolé mais ce code na marche pas. je joins un fichier.

Merci

'Option Explicit

Private Sub Worksheet_Activate()

'desactive protection
    Dim f As Worksheet
    Set f = ActiveSheet
    f.Protect Password:="", UserInterfaceOnly:=True

'active calcul manuel
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Range("t11:t100").Select
    Selection.ClearContents

Dim i As Integer
Dim nf As Worksheet

    Dim num As Integer
    num = Sheets("CR n°").Index + 1
    For i = num To Sheets.Count
      Set nf = Sheets(i)
      ActiveSheet.Hyperlinks.Add Anchor:=Cells(i + 4, 20), Address:="", SubAddress:="'" & _
         nf & "'" & "!A1", TextToDisplay:=nf

    Next i

Sheets("sommaire").Activate

        Range("T8:T100").Select
    With Selection.Font
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
    End With
    Selection.Font.Underline = xlUnderlineStyleNone
    Selection.Font.Italic = False
    Selection.Font.Bold = True
    Selection.Font.Size = 18
    With Selection.Font
        .Name = "AvantGarde S"
        .Size = 18
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Underline = xlUnderlineStyleNone
        .Shadow = False
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With

    Range("t11").Select

    'active calcul automatique
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

End Sub
12classeur2.xlsm (19.97 Ko)
Le 27/06/2022 à 11:54

Dans la suite de ton code tu utilise la variable nf comme si c'était du texte ! il faut savoir ce que tu veux qu'elle soit et à quoi elle sert :)

nf & "'" & "!A1", TextToDisplay:=nf

Essayes comme cela:

'Option Explicit

Private Sub Worksheet_Activate()

'desactive protection
    Dim f As Worksheet
    Set f = ActiveSheet
    f.Protect Password:="", UserInterfaceOnly:=True

'active calcul manuel
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Range("t11:t100").Select
    Selection.ClearContents

Dim i As Integer
Dim nf As String

    Dim num As Integer
    num = Sheets("CR n°").Index + 1
    For i = num To Sheets.Count
      nf = Sheets(i).Name
      ActiveSheet.Hyperlinks.Add Anchor:=Cells(i + 4, 20), Address:="", SubAddress:="'" & _
         nf & "'" & "!A1", TextToDisplay:=nf

    Next i

Sheets("sommaire").Activate

        Range("T8:T100").Select
    With Selection.Font
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
    End With
    Selection.Font.Underline = xlUnderlineStyleNone
    Selection.Font.Italic = False
    Selection.Font.Bold = True
    Selection.Font.Size = 18
    With Selection.Font
        .Name = "AvantGarde S"
        .Size = 18
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Underline = xlUnderlineStyleNone
        .Shadow = False
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With

    Range("t11").Select

    'active calcul automatique
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

End Sub
Rechercher des sujets similaires à "lister onglets feuille liens hypertexte"