Problème avec la création de lien hypertexte VBA vers une feuille existante

Le 14/01/2025 à 21:14

Je travaille sur un script VBA pour créer un lien hypertexte vers une feuille spécifique si elle existe. Le code semble détecter que la feuille existe puisque le message d'erreur ne s'affiche pas, mais lorsque je clique sur la cellule de la colonne G, le lien ne redirige vers rien.

Voici la partie concernée de mon code :

'Si la feuille existe, créer le lien

If Not wsAnnexe Is Nothing Then

' Créer le lien hypertexte vers l'onglet (feuille) de l'annexe

ws.hyperlinks.Add _

Anchor:=ws.Cells(i, 7), _

Address:="", _

SubAddress:="'" & annexeName & "'!A1", _

TextToDisplay:=ws.Cells(i, 7).Value

Else

' Si la feuille n'existe pas, afficher un message d'erreur

MsgBox "La feuille '" & annexeName & "' est introuvable.", vbExclamation

End If

End If

End If

Next i

edit modération : code mis entre balises en utilisant le bouton </>, merci d'y penser à l'avenir.

Le problème est que même si la feuille existe et le code ne déclenche pas le message d'erreur, le lien hypertexte créé ne fonctionne pas. Quand je clique sur la cellule, cela ne fait rien.

Une idée de ce qui pourrait poser problème ?

Le 15/01/2025 à 00:12

bonjour,

Tu ne nous donnes pas tout le code, on doit donc deviner ce qui précède les quelques lignes que tu as mises.

Je fais l'hypothèse que ceci devrait résoudre ton problème.

                'Si la feuille existe, créer le lien
                If Not wsAnnexe Is Nothing Then
                    ' Créer le lien hypertexte vers l'onglet (feuille) de l'annexe
                    ws.Hyperlinks.Add _
                    Anchor:=ws.Cells(i, 7), _
                    Address:="", _
                    SubAddress:="'" & wsAnnexe.Name & "'!A1", _
                    TextToDisplay:=ws.Cells(i, 7).Value
                Else
                    ' Si la feuille n'existe pas, afficher un message d'erreur
                    MsgBox "La feuille '" & wsAnnexe.Name & "' est introuvable.", vbExclamation
                End If
            End If
        End If
    Next i
Le 15/01/2025 à 08:09

Bonjour,

Voici mon code en entier

Sub CreateFCE()

Dim ws As Worksheet

Dim wb As Workbook

Dim NomFichier As String

Dim NomFeuille As String

Dim cheminFichier As String

Dim i As Integer

Dim lastRow As Long

Dim currentDate As String

Dim maxRowHeight As Double

Dim cell As Range

Dim tempHeight As Double

Dim annexeName As String

' Récupérer le nom du fichier cible à partir de la cellule A10 de Feuil1 de TEST4

NomFichier = ThisWorkbook.Sheets("Feuil1").Range("A10").Value

cheminFichier= \\ Cheminmodifier-Projet - CNouveau\10_lpb\0-Service IRl\5-Logiciel\TEST D\" & NomFichier & ".xlsx"

' Vérifier si le fichier existe avant de continuer

If Dir(cheminFichier) = "" Then

MsgBox "Le fichier '" & cheminFichier & "' n'existe pas. Veuillez vérifier le chemin ou le nom.", vbExclamation

Exit Sub

End If

' Ouvrir le fichier externe

Set wb = Workbooks.Open(cheminFichier)

' Récupérer le nom de la feuille cible (valeur de B10 dans Feuil1 de TEST4)

NomFeuille = ThisWorkbook.Sheets("Feuil1").Range("B10").Value

' Vérifier si la feuille existe dans le fichier ouvert

On Error Resume Next

Set ws = wb.Sheets(NomFeuille)

On Error GoTo 0

If ws Is Nothing Then

MsgBox "La feuille '" & NomFeuille & "' est introuvable dans le fichier '" & NomFichier & "'.", vbExclamation

wb.Close False

Exit Sub

End If

' Trouver la dernière ligne avec des données à partir de la ligne 2

lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row

For i = 8 To lastRow

If ws.Cells(i, 7).Value <> "" Then ' Si la cellule de la colonne G n'est pas vide

' Vérifier si la cellule contient "OUI"

If InStr(ws.Cells(i, 7).Value, "OUI") > 0 Then

' Extraire le nom de l'annexe après "OUI"

annexeName = Trim(Mid(ws.Cells(i, 7).Value, InStr(ws.Cells(i, 7).Value, "OUI") + 5))

' Vérifier si l'annexe contient "DOC"

If InStr(annexeName, "DOC") > 0 Then

' Déclarer la variable wsAnnexe

Dim wsAnnexe As Worksheet

' Vérifier si la feuille existe dans le classeur

On Error Resume Next

Set wsAnnexe = wb.Sheets(annexeName)

On Error GoTo 0

' Si la feuille existe, créer le lien

If Not wsAnnexe Is Nothing Then

' Créer le lien hypertexte vers l'onglet (feuille) de l'annexe

ws.hyperlinks.Add _

Anchor:=ws.Cells(i, 7), _

Address:="", _

SubAddress:="'" & annexeName & "'!A1", _

TextToDisplay:=ws.Cells(i, 7).Value

Else

' Si la feuille n'existe pas, afficher un message d'erreur

MsgBox "La feuille '" & annexeName & "' est introuvable.", vbExclamation

End If

End If

End If

Next i

' Copier les données de la ligne 2 à la dernière ligne trouvée et les coller à partir de la ligne 8

For i = 1 To 17 ' De A à P (16 colonnes)

ws.Range(ws.Cells(2, i), ws.Cells(lastRow, i)).Copy Destination:=ws.Cells(8, i)

Next i

'Ajouter la validation de données pour la liste déroulante en R8 à R1000

Dim validationRange As Range

Set validationRange = ws.Range("R8:R1000") ' La plage où la validation doit être appliquée

With validationRange.Validation

.Delete ' Supprimer la validation existante si elle existe

.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="Leila;Antoine;Paul" ' Liste des options séparées par des points-virgules

.IgnoreBlank = True

.InCellDropdown = True ' Afficher la flèche pour dérouler

.ShowInput = True ' Montrer le message d'entrée

.ShowError = True ' Montrer l'erreur si nécessaire

End With

'Le reste est de la mise en forme

' Ajouter une colonne "Acteurs" en R7

ws.Cells(7, 18).Value = "Acteurs"

ws.Cells(7, 18).Font.Bold = True

ws.Cells(7, 18).HorizontalAlignment = xlCenter

ws.Cells(7, 18).VerticalAlignment = xlCenter

ws.Cells(7, 18).Font.Size = 10

ws.Cells(7, 18).Font.Name = "Arial"

ws.Cells(7, 18).Font.Color = RGB(255, 255, 255) ' Blanc

ws.Cells(7, 18).Interior.Color = RGB(255, 0, 0) ' Rouge

' Appliquer un style à la cellule R8 (et à toutes les cellules de la plage R8:R1000)

For i = 8 To 1000

With ws.Cells(i, 18)

.HorizontalAlignment = xlCenter

.VerticalAlignment = xlCenter

.Font.Size = 8

.Font.Name = "Arial"

End With

Next i

' Appliquer Arial 8 et réinitialiser la couleur d'arrière-plan de la ligne 8 à la dernière ligne avec des données

For i = 8 To 1000

ws.Rows(i).Font.Name = "Arial"

ws.Rows(i).Font.Size = 8

Next i

' Initialiser la hauteur maximale

maxRowHeight = 0 ' Hauteur maximale de la ligne 8

' Parcours des cellules de la ligne 8 de A8 à Q8

For Each cell In ws.Range("A8:R8")

If cell.Value <> "" Then ' Si la cellule n'est pas vide

' Ajuste la hauteur de la cellule en fonction de son contenu

cell.Rows.AutoFit

' Récupérer la hauteur de la cellule et mettre à jour la hauteur maximale

tempHeight = cell.RowHeight

If tempHeight > maxRowHeight Then

maxRowHeight = tempHeight

End If

End If

Next cell

' Appliquer la hauteur maximale à la ligne 8

ws.Rows(8).RowHeight = maxRowHeight

' Appliquer la couleur en fonction de la valeur dans la colonne K de la ligne 8 à la dernière ligne

For i = 8 To 1000

If ws.Cells(i, 11).Value = "true" Then

' Appliquer la couleur #FBE2D5 sur A8:Dn+1 et F8:G n+1, et #FFFFCC sur E8:En+1

ws.Range("A" & i & ":D" & i).Interior.Color = RGB(251, 226, 213) ' #FBE2D5

ws.Range("E" & i & ":E" & i).Interior.Color = RGB(255, 255, 204) ' #FFFFCC

ws.Range("F" & i & ":G" & i).Interior.Color = RGB(251, 226, 213) ' #FBE2D5

ElseIf ws.Cells(i, 11).Value = "false" Then

' Appliquer la couleur #C0E6F5 sur A8:Dn+1 et F8:G n+1, et #FFFFCC sur E8:En+1

ws.Range("A" & i & ":D" & i).Interior.Color = RGB(192, 230, 245) ' #C0E6F5

ws.Range("E" & i & ":E" & i).Interior.Color = RGB(255, 255, 204) ' #FFFFCC

ws.Range("F" & i & ":G" & i).Interior.Color = RGB(192, 230, 245) ' #C0E6F5

End If

Next i

' Appliquer le filtre automatique sur la ligne 7

ws.Rows(7).AutoFilter

' Assurez-vous que la ligne 2 est vide après le déplacement (si nécessaire)

ws.Rows(2).ClearContents

' Configuration de l'orientation en paysage

ws.PageSetup.Orientation = xlLandscape

' *** Ajout de l'en-tête ***

currentDate = Date ' La date actuelle pour la création de la mise en page

With ws.PageSetup

.CenterHeader = "&""Arial,Bold""&14 FCE" ' Texte "FCE" centré en gras noir

.RightHeader = "&""Arial,Bold""&12 " & currentDate ' Date de création en haut à droite

.LeftHeader = "" ' Vous pouvez ajouter un en-tête à gauche si nécessaire

.TopMargin = Application.InchesToPoints(0.5) ' Réduire la marge du haut

.BottomMargin = Application.InchesToPoints(0.5) ' Réduire la marge du bas

.LeftMargin = Application.InchesToPoints(0.5) ' Réduire la marge gauche

.RightMargin = Application.InchesToPoints(0.5) ' Réduire la marge droite

End With

' Autres parties de votre code ici...

' *** Fusionner les cellules B2 à P2, fond noir et réduire la hauteur ***

With ws.Range("A2:R2")

.Merge

.Value = "" ' Laisser vide ou ajouter un texte si nécessaire

.Interior.Color = RGB(0, 0, 0) ' Noir

.Font.Color = RGB(255, 255, 255) ' Blanc

.HorizontalAlignment = xlCenter

.VerticalAlignment = xlCenter

End With

ws.Rows(2).RowHeight = ws.Rows(2).RowHeight - 6 ' Réduire la hauteur de la ligne B2:P2 de 2

' Autres parties de votre code ici...

' *** Ajouter des titres dans les lignes B3 à P4 ***

With ws.Range("A3:R4")

.Merge

.Value = "" ' Laisser vide ou ajouter un texte si nécessaire

.Font.Color = RGB(255, 255, 255) ' Blanc

.HorizontalAlignment = xlCenter

.VerticalAlignment = xlCenter

End With

' *** Ajouter des titres dans les lignes B6 à P6 ***

With ws.Range("A6:R6")

.Merge

.Value = "" ' Laisser vide ou ajouter un texte si nécessaire

.Font.Color = RGB(255, 255, 255) ' Blanc

.HorizontalAlignment = xlCenter

.VerticalAlignment = xlCenter

End With

' Ligne 5 : Fusionner A5:G5, écrire "Appel" en Arial 12, fond gris clair

With ws.Range("A5:H5")

.Merge

.Value = "Appel"

.Font.Bold = True

.Font.Size = 12

.Font.Name = "Arial"

.HorizontalAlignment = xlCenter

.VerticalAlignment = xlCenter

.Interior.Color = RGB(199, 199, 199) ' Gris clair

.Borders.Weight = xlThin

End With

' Ligne 5 : Fusionner H5:P5, écrire "ASTRID" en Arial 12, fond noir avec texte blanc

With ws.Range("I5:N5")

.Merge

.Value = "ASTRID"

.Font.Bold = True

.Font.Size = 12

.Font.Name = "Arial"

'.Font.Color = RGB(255, 255, 255) ' Blanc

.HorizontalAlignment = xlCenter

.VerticalAlignment = xlCenter

.Interior.Color = RGB(159, 159, 159) ' Noir

.Borders.Weight = xlThin

End With

With ws.Range("O5:R5")

.Merge

.Value = "TRACABILITE"

.Font.Bold = True

.Font.Size = 12

.Font.Name = "Arial"

'.Font.Color = RGB(255, 255, 255) ' Blanc

.HorizontalAlignment = xlCenter

.VerticalAlignment = xlCenter

.Interior.Color = RGB(128, 128, 128) ' Noir

.Borders.Weight = xlThin

End With

' Ligne 7 : Copier les titres de la ligne 1 dans la ligne 7

For col = 1 To 17 ' De A à P (16 colonnes)

With ws.Cells(7, col)

.Value = ws.Cells(1, col).Value ' Copier les titres de A1 à P1 dans la ligne 7

.Font.Bold = True

.Font.Size = 10

.Font.Name = "Arial"

.Font.Color = RGB(255, 255, 255) ' Blanc

.Interior.Color = RGB(255, 0, 0) ' Rouge

End With

Next col

' Fusionner les cellules de la ligne 1 de A1 à Q1

With ws.Range("A1:R1")

.Merge

.Value = "" ' Effacer le contenu de la cellule fusionnée

End With

' Réduire la hauteur de la ligne 1 par un facteur de 3

ws.Rows(1).RowHeight = ws.Rows(1).RowHeight / 5

' Ajouter un filtre pour les colonnes A7 à P7

ws.Rows(7).RowHeight = ws.Rows(7).RowHeight * (4 / 3)

' Réduire la hauteur de la ligne 5 de 2/3

ws.Rows(5).RowHeight = ws.Rows(5).RowHeight * (1 / 10)

' Réduire la hauteur des lignes 3, 4 et 6 de 3/4

ws.Rows(3).RowHeight = ws.Rows(3).RowHeight * (1 / 50)

ws.Rows(4).RowHeight = ws.Rows(4).RowHeight * (1 / 50)

ws.Rows(6).RowHeight = ws.Rows(6).RowHeight * (1 / 50)

' Ajuster la taille des colonnes de A à P

ws.Columns("A:R").AutoFit

' Réduire la longueur des colonnes comme décrit

ws.Columns("A:A").ColumnWidth = ws.Columns("A:A").ColumnWidth * (4 / 3) ' Réduire un tiers

ws.Columns("B:B").ColumnWidth = ws.Columns("B:B").ColumnWidth * (2 / 3) ' Réduire un tiers

ws.Columns("D:D").ColumnWidth = ws.Columns("D:D").ColumnWidth * (3 / 2) ' Réduire un tiers

ws.Columns("E:E").ColumnWidth = ws.Columns("E:E").ColumnWidth * (4 / 1) ' Réduire un tiers

ws.Columns("F:F").ColumnWidth = ws.Columns("F:F").ColumnWidth * (8 / 2) ' Réduire de 25%

'ws.Columns("G:G").ColumnWidth = ws.Columns("G:G").ColumnWidth * (2 / 4) ' Réduire de 25%

ws.Columns("H:H").ColumnWidth = ws.Columns("H:H").ColumnWidth * 0.8

ws.Columns("J:J").ColumnWidth = ws.Columns("J:J").ColumnWidth * (5 / 6) ' Réduire de 25%

ws.Columns("K:K").ColumnWidth = ws.Columns("K:K").ColumnWidth * (3 / 4)

ws.Columns("O:O").ColumnWidth = ws.Columns("O:O").ColumnWidth * (5 / 6) ' Réduire de 25%

ws.Columns("P:P").ColumnWidth = ws.Columns("P:P").ColumnWidth * (3 / 2) ' Réduire de 25%

ws.Columns("Q:Q").ColumnWidth = ws.Columns("Q:Q").ColumnWidth * (2 / 3) ' Réduire de 25%

ws.Columns("R:R").ColumnWidth = ws.Columns("R:R").ColumnWidth * (2 / 3) ' Réduire de 25

' Mise en forme des cellules dans la ligne 7 avec couleur et police

ws.Range("A7:R7").Interior.Color = RGB(255, 0, 0) ' Fond rouge pour toute la ligne

ws.Range("A7:R7").Font.Color = RGB(255, 255, 255) ' Texte blanc

' *** Trait noir épais de la colonne A5 à P5 ***

With ws.Range("A5:R5").Borders(xlEdgeBottom)

.LineStyle = xlContinuous

.Color = RGB(0, 0, 0) ' Noir

.Weight = xlThick ' Trait épais

End With

' Définir la zone d'impression de A1 à P1000

ws.PageSetup.PrintArea = "$A$1:$R$1000"

' Configuration de la mise en page

With ws.PageSetup

.Zoom = False

.FitToPagesWide = 1 ' Ajuster la largeur à une page

.FitToPagesTall = False ' Ajuster la hauteur à une page

.TopMargin = Application.InchesToPoints(1)

.BottomMargin = Application.InchesToPoints(0.5)

.LeftMargin = Application.InchesToPoints(0.5)

.RightMargin = Application.InchesToPoints(0.5)

End With

End Sub
Le 15/01/2025 à 09:50

bonjour,

A l'avenir, peux-tu mettre ton code entre balises </> en utilisant le bouton "</>" dans la barre de menu du message ? Merci

Je vois des erreurs dans ce code,

1) il manque un " avant \\ dans,.

cheminFichier= \\ Cheminmodifier-Projet - CNouveau\10_lpb\0-Service IRl\5-Logiciel\TEST D\" & NomFichier & ".xlsx"

2) il manque un End If

pour ces 2 erreurs tu reçois une erreur de compilation qui fait que ce code ne peut pas fonctionner !

3) l'instruction Dir ne fonctionne pas avec un adressage réseau et donc tu devrais normalement recevoir un message te disant que le fichier n'existe pas ...

mais comme tu ne reçois pas de message, j'en déduis, que tu as modifié cheminfichier ...

Après correction de ces problèmes et pour autant que le contenu de tes fichiers soit correct, la macro devrait fonctionner (Elle fonctionne chez moi)

Le 15/01/2025 à 10:05

Bonjour,

Merci pour les remarques j'ai effectivement modifié le chemin et tout fonctionne bien de mon côté aussi c'est simplement la partie liens hypertextes qui ne fonctionne pas, ce que je veux dire par la c'est que j'ai une mise en forme parfaite avec un fichier appelé qui existe etc.. mais simplement dans le code je demande dans la colonne G d'appelé les cellules ayant des Oui et donc si Oui alors de me renvoyer à la la feuille (ou bien l'annexe) il comprend bien le Oui mais ne renvoie à aucune feuille annexe, je n'ai pas non plus de message d'erreur qui me dis que mes annexes n'existent pas, et je ne comprends pas pourquoi

Le 15/01/2025 à 10:26

re-,

outre le test de la présence du OUI, il y également un test sur la présence des caractères "DOC",

pour debugger tu peux mettre un msgbox annexename après l'instruction annexename

annexeName = Trim(Mid(ws.Cells(i, 7).Value, InStr(ws.Cells(i, 7).Value, "OUI") + 5))
msgbox annexename
Le 15/01/2025 à 10:57

Yes c'est fait et ça me renvoie bien le bon nom d'annexe donc je ne sais pas d'où le soucis peut venir :

image image image

J'ai beau cliqué ça ne fait pas de renvoie

Le 15/01/2025 à 11:36

Bonjour,

Apparemment, le lien se perd lors de la mise en forme. je regarderai ce soir.

Le 15/01/2025 à 11:51

Super merci beaucoup

Le 15/01/2025 à 16:32

re,

c'est durant la copie des lignes vers la ligne 8 que les liens sont effacés.

je n'ai pas essayé de comprendre ta mise en page, mais j'ai d'abord fait la copie des lignes et ensuite généré les hyperliens. Voici le bout du code adapté. Vérifie que la mise en page souhaitée est restée correcte.

' Ouvrir le fichier externe

Set wb = Workbooks.Open(cheminFichier)

' Récupérer le nom de la feuille cible (valeur de B10 dans Feuil1 de TEST4)

NomFeuille = ThisWorkbook.Sheets("Feuil1").Range("B10").Value

' Vérifier si la feuille existe dans le fichier ouvert

On Error Resume Next

Set ws = wb.Sheets(NomFeuille)

On Error GoTo 0

If ws Is Nothing Then

MsgBox "La feuille '" & NomFeuille & "' est introuvable dans le fichier '" & NomFichier & "'.", vbExclamation

wb.Close False

Exit Sub

End If

' Trouver la dernière ligne avec des données à partir de la ligne 2

lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
' Copier les données de la ligne 2 à la dernière ligne trouvée et les coller à partir de la ligne 8

ws.Range(ws.Cells(2, 1), ws.Cells(lastRow, 17)).Copy ws.Cells(8, 1).Resize(lastRow - 2, 17)
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row

For i = 8 To lastRow

If ws.Cells(i, 7).Value <> "" Then ' Si la cellule de la colonne G n'est pas vide

' Vérifier si la cellule contient "OUI"

If InStr(ws.Cells(i, 7).Value, "OUI") > 0 Then

' Extraire le nom de l'annexe après "OUI"

annexeName = Trim(Mid(ws.Cells(i, 7).Value, InStr(ws.Cells(i, 7).Value, "OUI") + 5))

' Vérifier si l'annexe contient "DOC"

If InStr(annexeName, "DOC") > 0 Then

' Déclarer la variable wsAnnexe

Dim wsAnnexe As Worksheet

' Vérifier si la feuille existe dans le classeur

On Error Resume Next

Set wsAnnexe = wb.Sheets(annexeName)

On Error GoTo 0

' Si la feuille existe, créer le lien

If Not wsAnnexe Is Nothing Then

' Créer le lien hypertexte vers l'onglet (feuille) de l'annexe

ws.Hyperlinks.Add _
Anchor:=ws.Cells(i, 7), _
Address:="", _
SubAddress:="'" & annexeName & "'!A1", _
TextToDisplay:=ws.Cells(i, 7).Value

Else

' Si la feuille n'existe pas, afficher un message d'erreur

MsgBox "La feuille '" & annexeName & "' est introuvable.", vbExclamation

End If

End If

End If
End If

Next i

'suppression de la copie

'Ajouter la validation de données pour la liste déroulante en R8 à R1000
Le 15/01/2025 à 17:29

Re,

Merci pour ce bout de code alors je l'ai utilisé mais ça n'a rien donné non plus la mise en forme n'est pas impacté mais toujours le même problème aucun lien hypertexte, avez vous peut être d'autre idée ?

Le 15/01/2025 à 18:04

voici le code complet qui fonctionne chez moi, avec les modifications des instructions de mise en page. Il faudra que tu adaptes la ligne cheminfichier.

Sub CreateFCE()
    Dim ws As Worksheet
    Dim wb As Workbook
    Dim NomFichier As String
    Dim NomFeuille As String
    Dim cheminFichier As String
    Dim i As Integer
    Dim lastRow As Long
    Dim currentDate As String
    Dim maxRowHeight As Double
    Dim cell As Range
    Dim tempHeight As Double
    Dim annexeName As String
    ' Récupérer le nom du fichier cible à partir de la cellule A10 de Feuil1 de TEST4

    NomFichier = ThisWorkbook.Sheets("Feuil1").Range("A10").Value
    cheminFichier = "d:\downloads\" & NomFichier & ".xlsx" '<-------------------- à adapter

    ' Vérifier si le fichier existe avant de continuer
    If Dir(cheminFichier) = "" Then
        MsgBox "Le fichier '" & cheminFichier & "' n'existe pas. Veuillez vérifier le chemin ou le nom.", vbExclamation
        Exit Sub
    End If

    ' Ouvrir le fichier externe
    Set wb = Workbooks.Open(cheminFichier)

    ' Récupérer le nom de la feuille cible (valeur de B10 dans Feuil1 de TEST4)
    NomFeuille = ThisWorkbook.Sheets("Feuil1").Range("B10").Value

    ' Vérifier si la feuille existe dans le fichier ouvert
    On Error Resume Next
    Set ws = wb.Sheets(NomFeuille)
    On Error GoTo 0
    If ws Is Nothing Then
        MsgBox "La feuille '" & NomFeuille & "' est introuvable dans le fichier '" & NomFichier & "'.", vbExclamation
        wb.Close False
        Exit Sub
    End If

    ' Trouver la dernière ligne avec des données à partir de la ligne 2
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row

    ' Copier les données de la ligne 2 à la dernière ligne trouvée et les coller à partir de la ligne 8
    ws.Range(ws.Cells(2, 1), ws.Cells(lastRow, 17)).Copy ws.Cells(8, 1).Resize(lastRow - 2, 17)
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row

    'creer les hyperliens
    For i = 8 To lastRow
        If ws.Cells(i, 7).Value <> "" Then ' Si la cellule de la colonne G n'est pas vide
            ' Vérifier si la cellule contient "OUI"
            If InStr(ws.Cells(i, 7).Value, "OUI") > 0 Then
                ' Extraire le nom de l'annexe après "OUI"
                annexeName = Trim(Mid(ws.Cells(i, 7).Value, InStr(ws.Cells(i, 7).Value, "OUI") + 5))
                ' Vérifier si l'annexe contient "DOC"
                If InStr(annexeName, "DOC") > 0 Then
                    ' Déclarer la variable wsAnnexe
    Dim wsAnnexe As Worksheet
                    ' Vérifier si la feuille existe dans le classeur
                    On Error Resume Next
                    Set wsAnnexe = wb.Sheets(annexeName)
                    On Error GoTo 0
                    ' Si la feuille existe, créer le lien
                    If Not wsAnnexe Is Nothing Then
                        ' Créer le lien hypertexte vers l'onglet (feuille) de l'annexe
                        ws.Hyperlinks.Add _
                        Anchor:=ws.Cells(i, 7), _
                        Address:="", _
                        SubAddress:="'" & annexeName & "'!A1", _
                        TextToDisplay:=ws.Cells(i, 7).Value
                    Else
                        ' Si la feuille n'existe pas, afficher un message d'erreur
                        MsgBox "La feuille '" & annexeName & "' est introuvable.", vbExclamation
                    End If
                End If
            End If
        End If
    Next i

    'Ajouter la validation de données pour la liste déroulante en R8 à R1000
    Dim validationRange As Range
    Set validationRange = ws.Range("R8:R1000") ' La plage où la validation doit être appliquée
    With validationRange.Validation
        .Delete ' Supprimer la validation existante si elle existe
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="Leila;Antoine;Paul" ' Liste des options séparées par des points-virgules
        .IgnoreBlank = True
        .InCellDropdown = True ' Afficher la flèche pour dérouler
        .ShowInput = True ' Montrer le message d'entrée
        .ShowError = True ' Montrer l'erreur si nécessaire
    End With

    'Le reste est de la mise en forme
    ' Ajouter une colonne "Acteurs" en R7
    ws.Cells(7, 18).Value = "Acteurs"
    ws.Cells(7, 18).Font.Bold = True
    ws.Cells(7, 18).HorizontalAlignment = xlCenter
    ws.Cells(7, 18).VerticalAlignment = xlCenter
    ws.Cells(7, 18).Font.Size = 10
    ws.Cells(7, 18).Font.Name = "Arial"
    ws.Cells(7, 18).Font.Color = RGB(255, 255, 255) ' Blanc
    ws.Cells(7, 18).Interior.Color = RGB(255, 0, 0) ' Rouge
    ' Appliquer un style à la cellule R8 (et à toutes les cellules de la plage R8:R1000)
    For i = 8 To 1000
        With ws.Cells(i, 18)
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .Font.Size = 8
            .Font.Name = "Arial"
        End With
    Next i
    ' Appliquer Arial 8 et réinitialiser la couleur d'arrière-plan de la ligne 8 à la dernière ligne avec des données
    For i = 8 To 1000
        ws.Rows(i).Font.Name = "Arial"
        ws.Rows(i).Font.Size = 8
    Next i

    ' Initialiser la hauteur maximale
    maxRowHeight = 0 ' Hauteur maximale de la ligne 8
    ' Parcours des cellules de la ligne 8 de A8 à Q8
    For Each cell In ws.Range("A8:R8")
        If cell.Value <> "" Then ' Si la cellule n'est pas vide
            ' Ajuste la hauteur de la cellule en fonction de son contenu
            cell.Rows.AutoFit
            ' Récupérer la hauteur de la cellule et mettre à jour la hauteur maximale
            tempHeight = cell.RowHeight
            If tempHeight > maxRowHeight Then
                maxRowHeight = tempHeight
            End If
        End If
    Next cell
    ' Appliquer la hauteur maximale à la ligne 8
    ws.Rows(8).RowHeight = maxRowHeight
    ' Appliquer la couleur en fonction de la valeur dans la colonne K de la ligne 8 à la dernière ligne
    For i = 8 To 1000
        If ws.Cells(i, 11).Value = "true" Then
            ' Appliquer la couleur #FBE2D5 sur A8:Dn+1 et F8:G n+1, et #FFFFCC sur E8:En+1
            ws.Range("A" & i & ":D" & i).Interior.Color = RGB(251, 226, 213) ' #FBE2D5
            ws.Range("E" & i & ":E" & i).Interior.Color = RGB(255, 255, 204) ' #FFFFCC
            ws.Range("F" & i & ":G" & i).Interior.Color = RGB(251, 226, 213) ' #FBE2D5
        ElseIf ws.Cells(i, 11).Value = "false" Then
            ' Appliquer la couleur #C0E6F5 sur A8:Dn+1 et F8:G n+1, et #FFFFCC sur E8:En+1
            ws.Range("A" & i & ":D" & i).Interior.Color = RGB(192, 230, 245) ' #C0E6F5
            ws.Range("E" & i & ":E" & i).Interior.Color = RGB(255, 255, 204) ' #FFFFCC
            ws.Range("F" & i & ":G" & i).Interior.Color = RGB(192, 230, 245) ' #C0E6F5
        End If
    Next i
    ' Appliquer le filtre automatique sur la ligne 7
    ws.Rows(7).AutoFilter
    ' Assurez-vous que la ligne 2 est vide après le déplacement (si nécessaire)
    ws.Rows(2).ClearContents
    ' Configuration de l'orientation en paysage
    ws.PageSetup.Orientation = xlLandscape
    ' *** Ajout de l'en-tête ***
    currentDate = Date ' La date actuelle pour la création de la mise en page
    With ws.PageSetup
        .CenterHeader = "&""Arial,Bold""&14 FCE" ' Texte "FCE" centré en gras noir
        .RightHeader = "&""Arial,Bold""&12 " & currentDate ' Date de création en haut à droite
        .LeftHeader = "" ' Vous pouvez ajouter un en-tête à gauche si nécessaire
        .TopMargin = Application.InchesToPoints(0.5) ' Réduire la marge du haut
        .BottomMargin = Application.InchesToPoints(0.5) ' Réduire la marge du bas
        .LeftMargin = Application.InchesToPoints(0.5) ' Réduire la marge gauche
        .RightMargin = Application.InchesToPoints(0.5) ' Réduire la marge droite
    End With

    ' Autres parties de votre code ici...
    ' *** Fusionner les cellules B2 à P2, fond noir et réduire la hauteur ***
    With ws.Range("A2:R2")
        .Merge
        .Value = "" ' Laisser vide ou ajouter un texte si nécessaire
        .Interior.Color = RGB(0, 0, 0) ' Noir
        .Font.Color = RGB(255, 255, 255) ' Blanc
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
    End With
    ws.Rows(2).RowHeight = ws.Rows(2).RowHeight - 6 ' Réduire la hauteur de la ligne B2:P2 de 2
    ' Autres parties de votre code ici...
    ' *** Ajouter des titres dans les lignes B3 à P4 ***
    With ws.Range("A3:R4")
        .Merge
        .Value = "" ' Laisser vide ou ajouter un texte si nécessaire
        .Font.Color = RGB(255, 255, 255) ' Blanc
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
    End With

    ' *** Ajouter des titres dans les lignes B6 à P6 ***
    With ws.Range("A6:R6")
        .Merge
        .Value = "" ' Laisser vide ou ajouter un texte si nécessaire
        .Font.Color = RGB(255, 255, 255) ' Blanc
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
    End With
    ' Ligne 5 : Fusionner A5:G5, écrire "Appel" en Arial 12, fond gris clair
    With ws.Range("A5:H5")
        .Merge
        .Value = "Appel"
        .Font.Bold = True
        .Font.Size = 12
        .Font.Name = "Arial"
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .Interior.Color = RGB(199, 199, 199) ' Gris clair
        .Borders.Weight = xlThin
    End With
    ' Ligne 5 : Fusionner H5:P5, écrire "ASTRID" en Arial 12, fond noir avec texte blanc
    With ws.Range("I5:N5")
        .Merge
        .Value = "ASTRID"
        .Font.Bold = True
        .Font.Size = 12
        .Font.Name = "Arial"
        '.Font.Color = RGB(255, 255, 255) ' Blanc
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .Interior.Color = RGB(159, 159, 159) ' Noir
        .Borders.Weight = xlThin
    End With
    With ws.Range("O5:R5")
        .Merge
        .Value = "TRACABILITE"
        .Font.Bold = True
        .Font.Size = 12
        .Font.Name = "Arial"
        '.Font.Color = RGB(255, 255, 255) ' Blanc
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .Interior.Color = RGB(128, 128, 128) ' Noir
        .Borders.Weight = xlThin
    End With
    ' Ligne 7 : Copier les titres de la ligne 1 dans la ligne 7
    For col = 1 To 17 ' De A à P (16 colonnes)
        With ws.Cells(7, col)
            .Value = ws.Cells(1, col).Value ' Copier les titres de A1 à P1 dans la ligne 7
            .Font.Bold = True
            .Font.Size = 10
            .Font.Name = "Arial"
            .Font.Color = RGB(255, 255, 255) ' Blanc
            .Interior.Color = RGB(255, 0, 0) ' Rouge
        End With
    Next col
    ' Fusionner les cellules de la ligne 1 de A1 à Q1
    With ws.Range("A1:R1")
        .Merge
        .Value = "" ' Effacer le contenu de la cellule fusionnée
    End With
    ' Réduire la hauteur de la ligne 1 par un facteur de 3
    ws.Rows(1).RowHeight = ws.Rows(1).RowHeight / 5
    ' Ajouter un filtre pour les colonnes A7 à P7
    ws.Rows(7).RowHeight = ws.Rows(7).RowHeight * (4 / 3)
    ' Réduire la hauteur de la ligne 5 de 2/3
    ws.Rows(5).RowHeight = ws.Rows(5).RowHeight * (1 / 10)
    ' Réduire la hauteur des lignes 3, 4 et 6 de 3/4
    ws.Rows(3).RowHeight = ws.Rows(3).RowHeight * (1 / 50)
    ws.Rows(4).RowHeight = ws.Rows(4).RowHeight * (1 / 50)
    ws.Rows(6).RowHeight = ws.Rows(6).RowHeight * (1 / 50)
    ' Ajuster la taille des colonnes de A à P
    ws.Columns("A:R").AutoFit
    ' Réduire la longueur des colonnes comme décrit
    ws.Columns("A:A").ColumnWidth = ws.Columns("A:A").ColumnWidth * (4 / 3) ' Réduire un tiers
    ws.Columns("B:B").ColumnWidth = ws.Columns("B:B").ColumnWidth * (2 / 3) ' Réduire un tiers
    ws.Columns("D:D").ColumnWidth = ws.Columns("D:D").ColumnWidth * (3 / 2) ' Réduire un tiers
    ws.Columns("E:E").ColumnWidth = ws.Columns("E:E").ColumnWidth * (4 / 1) ' Réduire un tiers
    ws.Columns("F:F").ColumnWidth = ws.Columns("F:F").ColumnWidth * (8 / 2) ' Réduire de 25%
    'ws.Columns("G:G").ColumnWidth = ws.Columns("G:G").ColumnWidth * (2 / 4) ' Réduire de 25%
    ws.Columns("H:H").ColumnWidth = ws.Columns("H:H").ColumnWidth * 0.8
    ws.Columns("J:J").ColumnWidth = ws.Columns("J:J").ColumnWidth * (5 / 6) ' Réduire de 25%
    ws.Columns("K:K").ColumnWidth = ws.Columns("K:K").ColumnWidth * (3 / 4)
    ws.Columns("O:O").ColumnWidth = ws.Columns("O:O").ColumnWidth * (5 / 6) ' Réduire de 25%
    ws.Columns("P:P").ColumnWidth = ws.Columns("P:P").ColumnWidth * (3 / 2) ' Réduire de 25%
    ws.Columns("Q:Q").ColumnWidth = ws.Columns("Q:Q").ColumnWidth * (2 / 3) ' Réduire de 25%
    ws.Columns("R:R").ColumnWidth = ws.Columns("R:R").ColumnWidth * (2 / 3) ' Réduire de 25
    ' Mise en forme des cellules dans la ligne 7 avec couleur et police
    ws.Range("A7:R7").Interior.Color = RGB(255, 0, 0) ' Fond rouge pour toute la ligne
    ws.Range("A7:R7").Font.Color = RGB(255, 255, 255) ' Texte blanc
    ' *** Trait noir épais de la colonne A5 à P5 ***
    With ws.Range("A5:R5").Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Color = RGB(0, 0, 0) ' Noir
        .Weight = xlThick ' Trait épais
    End With
    ' Définir la zone d'impression de A1 à P1000
    ws.PageSetup.PrintArea = "$A$1:$R$1000"
    ' Configuration de la mise en page
    With ws.PageSetup
        .Zoom = False
        .FitToPagesWide = 1 ' Ajuster la largeur à une page
        .FitToPagesTall = False ' Ajuster la hauteur à une page
        .TopMargin = Application.InchesToPoints(1)
        .BottomMargin = Application.InchesToPoints(0.5)
        .LeftMargin = Application.InchesToPoints(0.5)
        .RightMargin = Application.InchesToPoints(0.5)
    End With
End Sub
Le 15/01/2025 à 19:06

Merci,

J'essaie demain et je te fais un retour

Le 16/01/2025 à 09:46

Parfait ton code merci infiniment pour ton aide, je vais te souler encore un peu mais j'ai des cellules qui appels à plusieurs annexe comme ici

image

tu penses qu'il est possible de faire en sorte dans le code d'automatiser ça et donc d'ouvrir l'onglet DOC...000016 quand je clique dessus sinon ouvrir l'onglet DOC....0000117 en cliquant sur le nom ?

Le 16/01/2025 à 10:11

bonjour,

A ma connaissance, l'hyperlien est lié à une cellule pas au contenu partiel d'une cellule, donc pour ta demande, il faut 2 cellules.

Le 16/01/2025 à 10:26

Merci pour ton aide

Le 16/01/2025 à 15:26

Alors j'ai vu avec Chatgpt et il me conseil de faire ce code qui permet de mettre plusieurs liens hypertextes dans une même cellule

For i = 8 To lastRow
    If ws.Cells(i, 7).Value <> "" Then ' Si la cellule de la colonne G n'est pas vide
        ' Diviser le texte de la cellule en plusieurs parties en utilisant "DOC" comme séparateur
        Dim annexeParts() As String
        annexeParts = Split(ws.Cells(i, 7).Value, "DOC")

        ' Ajouter "DOC" au début de chaque élément sauf le premier
        For j = 1 To UBound(annexeParts)
            annexeParts(j) = "DOC" & annexeParts(j)
        Next j

        ' Créer un lien pour chaque annexe dans la cellule sans perdre les autres
        Dim currentText As String
        currentText = "" ' Texte pour reconstruire la cellule
        Dim linkStart As Integer
        linkStart = 1 ' Position de départ pour placer chaque lien

        ' Déclarer la variable wsAnnexe
        Dim wsAnnexe As Worksheet
        Dim fullText As String
        fullText = ws.Cells(i, 7).Value ' Texte complet de la cellule avant modification

        ' Parcourir chaque partie et ajouter un lien pour chaque annexe
        For j = 0 To UBound(annexeParts)
            annexeName = Trim(annexeParts(j))

            ' Vérifier si l'annexe contient "DOC"
            If InStr(annexeName, "DOC") > 0 Then
                ' Vérifier si la feuille existe dans le classeur
                Set wsAnnexe = Nothing
                On Error Resume Next
                Set wsAnnexe = wb.Sheets(annexeName)
                On Error GoTo 0

                ' Si la feuille existe, créer le lien
                If Not wsAnnexe Is Nothing Then
                    ' Ajouter le texte actuel
                    If currentText <> "" Then
                        currentText = currentText & " - " ' Ajouter un séparateur
                    End If
                    currentText = currentText & annexeName

                    ' Ajouter un lien hypertexte pour la partie du texte
                    ws.hyperlinks.Add _
                        Anchor:=ws.Cells(i, 7).Characters(linkStart, Len(annexeName)), _
                        Address:="", _
                        SubAddress:="'" & annexeName & "'!A1", _
                        TextToDisplay:=annexeName

                    ' Mettre à jour la position de départ pour le lien suivant
                    linkStart = linkStart + Len(annexeName) + 3 ' Le +3 est pour tenir compte de " - "
                Else
                    ' Si la feuille n'existe pas, afficher un message d'erreur
                    MsgBox "La feuille '" & annexeName & "' est introuvable.", vbExclamation
                End If
            End If
        Next j
    End If
Next i

Mais problème impossible d'exécuter car ça me met erreur de lien ou argument incorrect

Le 16/01/2025 à 17:03

Bonjour,

Comme indiqué par h2so4, c'est maximum 1 hyperlien par cellule. Désolé. ChatGPT ne passe pas au-dessus des lois.

Rechercher des sujets similaires à "probleme creation lien hypertexte vba feuille existante"