Copier cellules avec intervalles et coller en lien hypertext

Bonjour,

Je cherche a faire un copié collé de cellules.

Mais avec 2 spécificités.

1/ Les cellules a copier sont avec des intervalles, soit : B3, G3, L3 etc.

2/ Je voudrais qu'elles soient collées en colonne A a partir de la ligne 7 mais en format hypertext, pour me renvoyer a elle si je clique dessus.

Donc que B3 soit copier en A7, G3 en A8, L3 en A9 etc.

Une petite 3eme spécificité, si en colonne A c'était en ordre alphabétique ce serait top.

J’avoue ne pas comprendre comment faire une copie de cette façon la, pouvez vous m'aider?

Je joint un fichier d'exemple

Merci d'avance

bonjour,

une proposition

Sub aargh()
    dc = Cells(3, Columns.Count).End(xlToLeft).Column
    ActiveSheet.Hyperlinks.Delete
    ligne = 5
    For i = 2 To dc Step 5
        ligne = ligne + 1
        ActiveSheet.Hyperlinks.Add Anchor:=Cells(ligne, 1), Address:="", SubAddress:=Cells(3, i).Address, TextToDisplay:=Cells(3, i).Value
    Next i
    Range("A6:A" & ligne).Sort key1:=Range("A1"), order1:=xlAscending, Header:=xlNo
End Sub

Merci pour ta réponse,

Ca fonctionne presque parfaitement, en effet, le problème, c'est que sur ma colonne A se trouve 2 liens hypertext, Sommaire et Données Liste, qui amène a d'autres feuilles non présente dans l'exemple, mais dont j'ai besoin.

Peut on éviter la suppression de ces liens?

Enfin, beaucoup moins important, mais serait très pratique, c'est que quand on clique sur un lien hypertext créé, que la colonne soit au centre de l’écran (idéale 6eme colonne), et non totalement a droite.

Car si on regarde l'exemple, le lien créé est le nom d'un produit qui correspond a un ensemble de 5 colonnes, du coup c'est pas trop facile a gérer quand la colonne cible est totalement a droite et donc que les 4 autres sont masquées.

Merci d'avance

Bonjour,

Comment puis je empêcher l'effacement des liens hypertext déjà présent sur la colonne A?

Merci

bonjour,

une nouvelle proposition, ta 2ème demande n'est pas gérable via hyperlien (enfin, pas à ma connaissance). je t'ai mis une macro événementielle, cliquer sur la cellule en colonne 1 pour se positionner sur la bonne colonne.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Column = 1 And Target.Row > 5 And Target.Count = 1 Then
        If Target = "" Then Exit Sub
        Set re = Rows(3).Find(Target.Value, lookat:=xlWhole)
        Application.Goto re
        On Error Resume Next
        ActiveWindow.ScrollColumn = re.Column - 10
        On Error GoTo 0
    End If
End Sub

Sub cree_liste()
    dc = Cells(3, Columns.Count).End(xlToLeft).Column
    ligne = 5
    For i = 2 To dc Step 5
        ligne = ligne + 1
        Cells(ligne, 1) = Cells(3, i)
    Next i
    Range("A6:A" & ligne).Sort key1:=Range("A1"), order1:=xlAscending, Header:=xlNo
End Sub

Merci pour ta solution.

En fait je n'arrive pas a la placer dans mon dossier "réel" (trop gros pour l'uploader sur le forum).

Dans le dossier j'ai 9 feuilles comme l'exemple, en plus d'autres.

Quand je recopie la macro, elle effectue bien la liste, mais rien ne se passe quand je clique sur une des cellules

Je comprend pas pourquoi.

bonjour,

mets ceci dans le code du classeur (sélectionner thisworkbook dans l'éditeur VBA)

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    If Target.Column = 1 And Target.Row > 5 And Target.Count = 1 Then
        If Target = "" Then Exit Sub
        Set re = Rows(3).Find(Target.Value, lookat:=xlWhole)
        Application.Goto re
        On Error Resume Next
        ActiveWindow.ScrollColumn = re.Column - 10
        On Error GoTo 0
    End If
End Sub

et ceci dans un nouveau module

insérer, module

Sub cree_liste()
' créée une liste sur la feuille active
    dc = Cells(3, Columns.Count).End(xlToLeft).Column
    ligne = 5
    For i = 2 To dc Step 5
        ligne = ligne + 1
        Cells(ligne, 1) = Cells(3, i)
    Next i
    Range("A6:A" & ligne).Sort key1:=Range("A1"), order1:=xlAscending, Header:=xlNo
End Sub

Merci,

Tout semble fonctionner parfaitement.

Un grand MERCI encore.

Heuu,

est il possible de limiter l'action du VBA qui permet en cliquant sur une cellule, d'aller a cette dernière, aux seul feuilles commençant par AC. ?

En fait je viens de m’apercevoir, que cela fonctionne sur toutes les feuilles, du coup, je suis bien embêté sur d'autres, car un message d'erreur s'affiche.

bonjour,

code adapté à ta nouvelle demande.

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    If UCase(Left(Sh, 2)) <> "AC" Then Exit Sub
    If Target.Column = 1 And Target.Row > 5 And Target.Count = 1 Then
        If Target = "" Then Exit Sub
        Set re = Rows(3).Find(Target.Value, lookat:=xlWhole)
        Application.Goto re
        On Error Resume Next
        ActiveWindow.ScrollColumn = re.Column - 10
        On Error GoTo 0
    End If
End Sub

Merci H2so4, mais ca ne fonctionne pas.

un message d'erreur s'affiche :

Erreur d'exécution '438':

Propriété ou méthode non gérée par cet objet

Si je clique sur débogage, il me met en surbrillance : If UCase(Left(Sh, 2)) <> "AC" Then

Par contre, ca fonctionne plus du tout sur les feuille "AC.", meme message d'erreur.

Je suis désolé, je suis un gros noob en VBA

Ce serait surement plus simple avec le fichier, mais trop gros pour le forum.

Peut être quelques infos de plus sur mon dossier pourrait vous aider.

Il y a environ 140 feuilles

Classées par des nominations type AC. Farine, FB. Tarte, etc. les AC., FB. et autres permettent de trier les feuilles en fonction des groupes.

J'ai quelques macros dedans, je ne sais pas si cela peu gêner. 18 macros dans 7 modules et le tien en plus dans ThisWorkbook.

Je sais pas si cela est suffisant.

bonsoir,

désolé, j'avais fait la correction sans avoir eu la possibilité de tester. voici une correction.

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    If UCase(Left(Sh.Name, 2)) <> "AC" Then Exit Sub
    If Target.Column = 1 And Target.Row > 5 And Target.Count = 1 Then
        If Target = "" Then Exit Sub
        Set re = Rows(3).Find(Target.Value, lookat:=xlWhole)
        Application.Goto re
        On Error Resume Next
        ActiveWindow.ScrollColumn = re.Column - 10
        On Error GoTo 0
    End If
End Sub

Non mais sérieusement, comment peut on faire des erreurs a ce point.

Impardonnable.

Merci, tout semble bien fonctionner.