ThisWorkBook.Names

Le 09/08/2020 à 14:10

Bonjour membre du forum,

Je souhaiterai extraire le Gestionnaire de Nom sur une feuille dans un tableau précis avec les commentaires des formules.

Je joins le Fichier avec son début de code

11on-off-plein-ecran.xlsm (49.19 Ko)
Sub Extraire_GestionnaireDeNoms()
    Dim N As Name, A As Integer
    Sheets("Feuil1").Select

    Dim Sh As Worksheet
    Set Sh = ThisWorkBook.Worksheets.Add
    With Sh
        .Range("C5") = "FEUIL(n)"
        .Range("E5") = "ONGLETS"
        .Range("G5") = "NOMS"
        .Range("I5") = "FORMULE"
        .Range("K5") = "COMMENTAIRES"
        A = 1
        For Each N In ThisWorkBook.Names
            N.Visible = True
            A = A + 1
            .Range("G7" & A) = N.Name
            .Range("I7" & A) = "'" & N.RefersToLocal
        Next
        Cells.Select
        With Selection.Font
            .Name = "Courier New"
            .Size = 10
            .Strikethrough = False
            .Superscript = False
            .Subscript = False
            .OutlineFont = False
            .Shadow = False
            .TintAndShade = 0
            .ThemeFont = xlThemeFontNone
        End With

        ' ............................................................................................
        Range("C5").Select
        ActiveCell.FormulaR1C1 = "FEUIL(n)"
        With Selection.Font
            .Color = -6279056
            .TintAndShade = 0
        End With
        ' **** ---- ****
        Range("E5").Select
        ActiveCell.FormulaR1C1 = "ONGLETS"
        With Selection.Font
            .ThemeColor = xlThemeColorLight1
            .TintAndShade = 0.249977111117893
        End With
        ' **** ---- ****
        Range("G5").Select
        ActiveCell.FormulaR1C1 = "NOMS"
        With Selection.Font
            .Color = -4165632
            .TintAndShade = 0
        End With
        ' **** ---- ****
        Range("I5").Select
        ActiveCell.FormulaR1C1 = "FORMULE"
        With Selection.Font
            .Color = -16777024
            .TintAndShade = 0
        End With
        ' **** ---- ****
        Range("K5").Select
        ActiveCell.FormulaR1C1 = "COMMENTAIRES"
        With Selection.Font
            .Color = -11237609
            .TintAndShade = 0
        End With
        ' **** ---- ****
        Range("4:4,6:6").Select
        Selection.RowHeight = 7.5
        Rows("5:5").Select
        Selection.RowHeight = 28.5
        With Selection.Font
            .Name = "Impact"
            .Size = 22
            .Strikethrough = False
            .Superscript = False
            .Subscript = False
            .OutlineFont = False
            .Shadow = False
            .Underline = xlUnderlineStyleNone
            .TintAndShade = 0
            .ThemeFont = xlThemeFontNone
        End With
        ' **** ---- ****
        Range("C5,E5,G5,I5,K5").Select
        With Selection.Interior
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            .ThemeColor = xlThemeColorDark1
            .TintAndShade = 0
            .PatternTintAndShade = 0
        End With
        ' Celulle dans les colonnes et lignes intermédiaires du tableau en Vert
        Range("B4:L4,B6:L6,L5,J5,H5,F5,D5,B5,B7:B16,D7:D16,F7:F16,H7:H16,J7:J16,L7:L16").Select
        With Selection.Interior
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            .Color = 32768
            .TintAndShade = 0
            .PatternTintAndShade = 0
        End With
        Range("B:B,D:D,F:F,H:H,J:J,L:L").Select
        Range("L1").Activate
        Selection.ColumnWidth = 0.83
        ' Feuil(n)
        Range("C7:C15").Select
        With Selection.Interior
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            .Color = 8506404
            .TintAndShade = 0
            .PatternTintAndShade = 0
        End With
        ' Nom de la feuille
        Range("E7").Select
        With Selection.Interior
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            .Color = 13299357
            .TintAndShade = 0
            .PatternTintAndShade = 0
        End With
        Selection.Borders(xlDiagonalDown).LineStyle = xlNone
        Selection.Borders(xlDiagonalUp).LineStyle = xlNone
        With Selection.Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .Color = -65536
            .TintAndShade = 0
            .Weight = xlHairline
        End With
        With Selection.Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .Color = -65536
            .TintAndShade = 0
            .Weight = xlHairline
        End With
        With Selection.Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .Color = -65536
            .TintAndShade = 0
            .Weight = xlHairline
        End With
        With Selection.Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .Color = -65536
            .TintAndShade = 0
            .Weight = xlHairline
        End With
        Selection.Borders(xlInsideVertical).LineStyle = xlNone
        Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
        With Selection.Font
            .ThemeColor = xlThemeColorLight1
            .TintAndShade = 4.99893185216834E-02
        End With
        ' Nom de la Formule
        Range("G7:G15").Select
        With Selection.Interior
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            .ThemeColor = xlThemeColorAccent1
            .TintAndShade = 0.799981688894314
            .PatternTintAndShade = 0
        End With
        With Selection.Font
            .Color = -4165632
            .TintAndShade = 0
        End With
        ' La Formule
        Range("I7:I15").Select
        With Selection.Interior
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            .Color = 14540287
            .TintAndShade = 0
            .PatternTintAndShade = 0
        End With
        With Selection.Font
            .Color = -16777024
            .TintAndShade = 0
        End With
        ' Le commentaire
        Range("K7:K15").Select
        With Selection.Interior
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            .Color = 15596254
            .TintAndShade = 0
            .PatternTintAndShade = 0
        End With
        With Selection.Font
            .Color = -11237609
            .TintAndShade = 0
        End With
        ' bordure interne
        Range("G7:G15,I7:I15,K7:K15").Select
        Selection.Borders(xlDiagonalDown).LineStyle = xlNone
        Selection.Borders(xlDiagonalUp).LineStyle = xlNone
        With Selection.Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .Color = -65536
            .TintAndShade = 0
            .Weight = xlHairline
        End With
        With Selection.Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .Color = -65536
            .TintAndShade = 0
            .Weight = xlHairline
        End With
        With Selection.Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .Color = -65536
            .TintAndShade = 0
            .Weight = xlHairline
        End With
        With Selection.Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .Color = -65536
            .TintAndShade = 0
            .Weight = xlHairline
        End With
        Selection.Borders(xlInsideVertical).LineStyle = xlNone
        With Selection.Borders(xlInsideHorizontal)
            .LineStyle = xlContinuous
            .Color = -65536
            .TintAndShade = 0
            .Weight = xlHairline
        End With
        Cells.Select
        Selection.Columns.AutoFit
        Range("A1").Select
    End With
    On Error Resume Next
End Sub

Cordialement

Le 09/08/2020 à 14:51

bonjour,

une proposition à compléter

9on-off-plein-ecran.xlsm (53.18 Ko)
Le 09/08/2020 à 18:29

Bonjour h2so4

Voici ce que j'ai compris et ce que j'ai ajusté :

Sub Extraire_GestionnaireDeNoms()
    Dim N As Name, A As Integer
    Sheets("Feuil1").Select

    Dim Sh As Worksheet
    Set Sh = ThisWorkBook.Worksheets.Add
    With Sh
        .Range("C5") = "FEUIL(n)"
        .Range("E5") = "ONGLETS"
        .Range("G5") = "NOMS"
        .Range("I5") = "FORMULE"
        .Range("K5") = "COMMENTAIRES"
        A = 1
        For Each N In ThisWorkBook.Names
            N.Visible = True
            A = A + 1
            .Range("G" & 5 + A) = N.Name
            .Range("I" & 5 + A) = "'" & N.RefersToLocal
            .Range("K" & 5 + A) = N.Comment
        Next
        Cells.Select
        With Selection.Font
            .Name = "Courier New"
            .Size = 10
            .Strikethrough = False
            .Superscript = False
            .Subscript = False
            .OutlineFont = False
            .Shadow = False
            .TintAndShade = 0
            .ThemeFont = xlThemeFontNone
        End With

        ' ............................................................................................
        Range("C5").Select
        ActiveCell.FormulaR1C1 = "FEUIL(n)"
        With Selection.Font
            .Color = -6279056
            .TintAndShade = 0
        End With
        ' **** ---- ****
        Range("E5").Select
        ActiveCell.FormulaR1C1 = "ONGLETS"
        With Selection.Font
            .ThemeColor = xlThemeColorLight1
            .TintAndShade = 0.249977111117893
        End With
        ' **** ---- ****
        Range("G5").Select
        ActiveCell.FormulaR1C1 = "NOMS"
        With Selection.Font
            .Color = -4165632
            .TintAndShade = 0
        End With
        ' **** ---- ****
        Range("I5").Select
        ActiveCell.FormulaR1C1 = "FORMULE"
        With Selection.Font
            .Color = -16777024
            .TintAndShade = 0
        End With
        ' **** ---- ****
        Range("K5").Select
        ActiveCell.FormulaR1C1 = "COMMENTAIRES"
        With Selection.Font
            .Color = -11237609
            .TintAndShade = 0
        End With
        ' **** ---- ****
        Range("4:4,6:6").Select
        Selection.RowHeight = 7.5
        Rows("5:5").Select
        Selection.RowHeight = 28.5
        With Selection.Font
            .Name = "Impact"
            .Size = 22
            .Strikethrough = False
            .Superscript = False
            .Subscript = False
            .OutlineFont = False
            .Shadow = False
            .Underline = xlUnderlineStyleNone
            .TintAndShade = 0
            .ThemeFont = xlThemeFontNone
        End With
        ' **** ---- ****
        Range("C5,E5,G5,I5,K5").Select
        With Selection.Interior
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            .ThemeColor = xlThemeColorDark1
            .TintAndShade = 0
            .PatternTintAndShade = 0
        End With
        ' Celulle dans les colonnes et lignes intermédiaires du tableau en Vert
        Range("B4:L4,B6:L6,L5,J5,H5,F5,D5,B5,B7:B16,D7:D16,F7:F16,H7:H16,J7:J16,L7:L16").Select
        With Selection.Interior
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            .Color = 32768
            .TintAndShade = 0
            .PatternTintAndShade = 0
        End With
        Range("B:B,D:D,F:F,H:H,J:J,L:L").Select
        Range("L1").Activate
        Selection.ColumnWidth = 0.83
        ' Feuil(n)
        Range("C7:C15").Select
        With Selection.Interior
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            .Color = 8506404
            .TintAndShade = 0
            .PatternTintAndShade = 0
        End With
        'Range("C7").Select
        '
        ' Nom de la feuille
        Range("E7").Select
        ActiveCell.FormulaR1C1 = "Feuil1"
        With Selection.Interior
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            .Color = 13299357
            .TintAndShade = 0
            .PatternTintAndShade = 0
        End With
        Selection.Borders(xlDiagonalDown).LineStyle = xlNone
        Selection.Borders(xlDiagonalUp).LineStyle = xlNone
        With Selection.Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .Color = -65536
            .TintAndShade = 0
            .Weight = xlHairline
        End With
        With Selection.Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .Color = -65536
            .TintAndShade = 0
            .Weight = xlHairline
        End With
        With Selection.Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .Color = -65536
            .TintAndShade = 0
            .Weight = xlHairline
        End With
        With Selection.Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .Color = -65536
            .TintAndShade = 0
            .Weight = xlHairline
        End With
        Selection.Borders(xlInsideVertical).LineStyle = xlNone
        Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
        With Selection.Font
            .ThemeColor = xlThemeColorLight1
            .TintAndShade = 4.99893185216834E-02
        End With
        ' Nom de la Formule
        Range("G7:G15").Select
        With Selection.Interior
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            .ThemeColor = xlThemeColorAccent1
            .TintAndShade = 0.799981688894314
            .PatternTintAndShade = 0
        End With
        With Selection.Font
            .Color = -4165632
            .TintAndShade = 0
        End With
        ' La Formule
        Range("I7:I15").Select
        With Selection.Interior
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            .Color = 14540287
            .TintAndShade = 0
            .PatternTintAndShade = 0
        End With
        With Selection.Font
            .Color = -16777024
            .TintAndShade = 0
        End With
        ' Le commentaire
        Range("K7:K15").Select
        With Selection.Interior
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            .Color = 15596254
            .TintAndShade = 0
            .PatternTintAndShade = 0
        End With
        With Selection.Font
            .Color = -11237609
            .TintAndShade = 0
        End With
        ' bordure interne
        Range("G7:G15,I7:I15,K7:K15").Select
        Selection.Borders(xlDiagonalDown).LineStyle = xlNone
        Selection.Borders(xlDiagonalUp).LineStyle = xlNone
        With Selection.Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .Color = -65536
            .TintAndShade = 0
            .Weight = xlHairline
        End With
        With Selection.Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .Color = -65536
            .TintAndShade = 0
            .Weight = xlHairline
        End With
        With Selection.Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .Color = -65536
            .TintAndShade = 0
            .Weight = xlHairline
        End With
        With Selection.Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .Color = -65536
            .TintAndShade = 0
            .Weight = xlHairline
        End With
        Selection.Borders(xlInsideVertical).LineStyle = xlNone
        With Selection.Borders(xlInsideHorizontal)
            .LineStyle = xlContinuous
            .Color = -65536
            .TintAndShade = 0
            .Weight = xlHairline
        End With
        Cells.Select
        Selection.Columns.AutoFit
        Cells.Select
        Selection.Copy
        Sheets("Feuil1").Select

        Range("A1").Select
        ActiveSheet.Paste
        Sh.Select
        Application.CutCopyMode = False
        Application.DisplayAlerts = False
        Sh.Delete
        Application.DisplayAlerts = True
    End With
    Range("A1").Select
    Range("A1").Value = "Menu"
    Range("A1").Select
    ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:= _
        "Feuil1!A1", ScreenTip:="Retour", TextToDisplay:="Menu"
    With Selection.Font
        .Name = "Courier New"
        .Size = 11
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleSingle
        .ThemeColor = xlThemeColorHyperlink
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    On Error Resume Next
End Sub

Il me manque plus qu'à complet C7 et E7 et d'ensuite boucler la procédure pour les formules d'une autre feuille en stipulant qu'il faut repartir 2 lignes en dessous de la dernière ligne vide de la colonne G en réajustant la hauteur la couleur de la dernière ligne pour former le tableau

Rechercher des sujets similaires à "thisworkbook names"