ThisWorkBook.Names
Le_Troll_Du_27Membre fidèle
- Messages
- 156
- Excel
- 2019 FR 64 Bits
- Inscrit
- 14/07/2015
- Emploi
- Ex-Conducteur Routier de convoi exceptionnel
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
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_Troll_Du_27Membre fidèle
- Messages
- 156
- Excel
- 2019 FR 64 Bits
- Inscrit
- 14/07/2015
- Emploi
- Ex-Conducteur Routier de convoi exceptionnel
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