XL 2016 Aide Macro VBA - Reporter valeurs Feuille 1 dans une autre feuille 2 à partir d'une certaine cellule

[jo77]

Bonjour à vous,

Je bloque depuis un petit moment sur une macro que j'aimerai faire.
Sauf erreur de ma part, aucune formule Excel ne me permet de le faire.
C'est un peu l'équivalent d'un recherche V sauf que j'ai plusieurs lignes différentes à reporter sur une autre feuille.

Pour faire simple, voici les étapes en français :
Rechercher la valeur d'une cellule de la feuille 2 dans la colonne A de la feuille 1
Si la valeur est présente, alors recopier seulement les données des lignes de la colonne D, G, H, I, K.
Dans les colonnes C, D, E, F, G à partir de la cellule C86

La Macro ci-après fonctionne bien. Mais me recopie les valeurs à partir de C2. Or j'en ai besoin à partir de C86.

Merci pour votre aide

Option Explicit

Sub test()
Dim x As Long
Dim y As Long
Dim c As Range
Dim rdata As Range

' Déterminer la dernière ligne de la Feuille 1
x = Sheets("Actions - Risques").Range("A65536").End(xlUp).Row
' Déterminer la dernière ligne de la Feuille 2 + 1
y = Sheets("feuil5").Range("C65536").End(xlUp).Row + 1

' Déterminer la Plage de référence dans la Feuille 1
' dans la Colonne B ... à partir de la ligne 2 jusqu'à x
Set rdata = Sheets("Actions - Risques").Range("A2:A" & x)

' Effacer les anciennes lignes des anciennes demandes
If y >= 2 Then Sheets("feuil5").Range("A2:G" & y).ClearContents

' Boucle dans la plage de référence
For Each c In rdata
  ' Si la valeur de la cellule est égale à la
  ' valeur choisie en F2 de la Feuille 2
  If c.Value = Sheets("feuil5").Range("I13").Value Then
  ' dans ce cas, copier depuis la Feuille 1, la plage A:D
  ' vers la Feuille 2 dans la Colonne A à la premiére ligne libre
    Sheets("Actions - Risques").Range("D" & c.Row).Copy Destination:=Sheets("feuil5").Range("C" & y)
    Sheets("Actions - Risques").Range("G" & c.Row).Copy Destination:=Sheets("feuil5").Range("D" & y)
    Sheets("Actions - Risques").Range("H" & c.Row).Copy Destination:=Sheets("feuil5").Range("E" & y)
    Sheets("Actions - Risques").Range("I" & c.Row).Copy Destination:=Sheets("feuil5").Range("F" & y)
    Sheets("Actions - Risques").Range("K" & c.Row).Copy Destination:=Sheets("feuil5").Range("G" & y)
    
  End If
  ' Recalculer la première ligne libre de la Feuille 2
  y = Sheets("feuil5").Range("c65536").End(xlUp).Row + 1

' Retour de la boucle pour passer à la cellule suivante
Next c

End Sub

 

[Robert]

Bonjour Jo, bonjour le forum,

Il me semble que le recalcul de la première ligne vide devrait se faire dans la condition End... End If et non pas après...
Je te propose une autre solution bien plus rapide avec des variables tableaux à la place des plage (non testée) :

Sub test()
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim TV As Variant 'déclare la variable TV (Tableau des Valeurs)
Dim PLV As Long 'déclare la variable PLV (Première Ligne Vide)
Dim I As Integer 'déclare la variable I (Incrément)
Dim K As Integer 'déclare la variabler K (Incrément)
Dim TL() As Variant 'déclare la variabel TL (Tableau des Lignes)

Set OS = Worksheets("Actions - Risques") 'définit l'onglet source OS
Set OD = Worksheets("feuil5") 'définit l'onglet destination OD
TV = OS.Range("A1").CurrentRegion 'définit le tableau des valeurs TV
PLV = OD.Range("C65536").End(xlUp).Row + 1 'définit la première ligne vide PLV de la colonne C de l'onglet destination OD
' Effacer les anciennes lignes des anciennes demandes
If PLV >= 2 Then OD.Range("A2:G" & PLV -1 ).ClearContents 'pourquoi les colonnes A et B ?
For I = 2 To UBound(TV, 1) 'boucle sur toutes les lignes I du tableau des valeurs TV (en partant de la seconde)
    'condition : si la donnée ligne I colonne 1 de TV est égale à la valeur de la cellule I13 de l'onglet destination OD
    If TV(I, 1) = OD.Range("I13") Then
        K = K + 1 'incrémente K
        ReDim Preserve TL(1 To 5, 1 To K) 'redéfinit le tableau des lignes TL
        TL(1, K) = TV(I, 4) 'récupère la donnée ligne I colonne 4 de TV dans la ligne 1 colonne K de TL (=> Transposition)
        TL(2, K) = TV(I, 7) 'récupère la donnée ligne I colonne 7 de TV dans la ligne 2 colonne K de TL (=> Transposition)
        TL(3, K) = TV(I, 8) 'récupère la donnée ligne I colonne 8 de TV dans la ligne 3 colonne K de TL (=> Transposition)
        TL(4, K) = TV(I, 9) 'récupère la donnée ligne I colonne 9 de TV dans la ligne 4 colonne K de TL (=> Transposition)
        TL(5, K) = TV(I, 11) 'récupère la donnée ligne I colonne 11 de TV dans la ligne 5 colonne K de TL (=> Transposition)
    End If 'fin de la condition
Next I 'prochaine ligne de la boucle
'renvoie dans la cellule redimensionnée ligne PLV, colonne C, le tableau TL transposé
OD.Cells(PLV, "C").Resize(K, 5).Value = Application.Transpose(TL)
End Sub

 

[jo77]

Bonjour Robert,

Merci pour ta réponse. J'ai essayé ta macro mais malheureusement elle ne marche pas. Dois-je changer une variable ?
Je te joint un fichier pour exemple. Si je veux que les valeurs soient retranscrites dans le tableau en feuille 2 à partir de C15.

Merci à toi.
Jo

 

[Robert]

Re,

Remplace la ligne :

TV = OS.Range("A1").CurrentRegion 'définit le tableau des valeurs TV

par :

TV = OS.Range("A3").CurrentRegion 'définit le tableau des valeurs TV

Et, comme tu viens de le faire, envoie toujours un fichier exemple avec tes requêtes. Ça nous permet de tester avant de te proposer une réponse...

 

[jo77]

Merci Robert,

J'ai plus de message d'erreur. Cependant, lorsque je relance la Macro, ça supprime les valeurs et les décale vers le bas.
L'idée serait que cela supprime les valeurs mais les remette toujours au même endroit.
Si je rajoute des lignes dans l'onglet "Actions - Risques", qu'elles puissent apparaitre avec la "mise à jour" en relançant la MACRO.
Sachant que l'en-tête du tableau dans la feuille 2 ne changera pas et doit toujours rester visible.
Et que les données doivent être copiées juste en dessous de ces en-têtes.

Type - Action / Risque

Pilote

Description

Commentaire

Date de Besoin

Merci grandement pour ton aide.

Jo

 

[Phil69970]

Bonjour à tous

Je te propose ma version

*Merci de ton retour

@Phil69970

 

[jo77]

Bonjour à tous

Je te propose ma version

*Merci de ton retour

@Phil69970

Bonjour Phil,
Merci pour ton retour. Et ta version.

Deux petites remarques :
- Les lignes à copier doivent être faites en fonction d'une référence. (Ici cellule "I13" de la feuil5).
Si cette condition est réunie, alors il faut copier la ligne. Comme ton programme le fait déjà.

- Lorsque je relance la Macro, les lignes doivent justes être mises à jour. Entre-temps, si je rajoute une ligne dans l'onglet 1 avec la référence se trouvant en "I13", la nouvelle ligne doit apparaître.
Donc avec une fonction clear.content avant de pouvoir recopier les cellules au même endroit.
Actuellement, si je lance ta macro, les lignes se copient juste les unes à la suite des autres à chaque lancement de la macro.

- Enfin, lorsque j'essaie d'intégrer ta macro au fichier joint, celle-ci ne se lance pas. Et pourtant elle fonctionne dans ton fichier ?

Merci à toi.
Jo

 

[Phil69970]

Re

Voici le fichier modifié :

J'avais pas vu qu'il fallait comparer avec une cellule de référence

Ici cellule "I13" de la feuil5

- A chaque lancement de la macro j'efface tout et je reconstruis tout

Il faut bien affecter la macro au bouton ou à la forme....

Enfin, lorsque j'essaie d'intégrer ta macro au fichier joint, celle-ci ne se lance pas. Et pourtant elle fonctionne dans ton fichier ?

*Merci de ton retour

@Phil69970

 

[Robert]

Bonjour le fil, bonjour le forum,

La version corrigée :

Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim TV As Variant 'déclare la variable TV (Tableau des Valeurs)
Dim TSD As ListObject 'déclare la variable TSD (Tableau Structuré Destination)
Dim PTS As Range 'déclare la variable PTS (Plage du Tableau Structuré)
Dim I As Integer 'déclare la variable I (Incrément)
Dim J As Integer 'déclare la variabler K (Incrément)
Dim TL(1 To 1, 1 To 5) As Variant 'déclare la variabel TL (Tableau des Lignes)

Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
Set OS = Worksheets("Actions - Risques") 'définit l'onglet source OS
Set OD = Worksheets("feuil5") 'définit l'onglet destination OD
TV = OS.Range("A3").CurrentRegion 'définit le tableau des valeurs TV
Set TSD = OD.ListObjects("Tableau2") 'définit le tableau structuré TSD
Set PTS = TSD.DataBodyRange 'définit la plage PTS des données du tableau structuré (sans l'en t-ête)
PTS.ClearContents 'efface le contenu de la plage PTS
TSD.Resize Range("$C$14:$G$15") 'redimensionne le tableau TSD
For I = 2 To UBound(TV, 1) 'boucle sur toutes les lignes I du tableau des valeurs TV (en partant de la seconde)
    'condition : si la donnée ligne I colonne 1 de TV est égale à la valeur de la cellule I13 de l'onglet destination OD
    If TV(I, 1) = OD.Range("I13") Then
        J = J + 1 'incrémente J
        TL(1, 1) = TV(I, 4) 'récupère la donnée ligne I colonne 4 de TV dans la ligne 1 colonne 1 de TL
        TL(1, 2) = TV(I, 7) 'récupère la donnée ligne I colonne 7 de TV dans la ligne 2 colonne 2 de TL
        TL(1, 3) = TV(I, 8) 'récupère la donnée ligne I colonne 8 de TV dans la ligne 3 colonne 3 de TL
        TL(1, 4) = TV(I, 9) 'récupère la donnée ligne I colonne 9 de TV dans la ligne 4 colonne 4 de TL
        TL(1, 5) = TV(I, 11) 'récupère la donnée ligne I colonne 11 de TV dans la ligne 5 colonne 5 de TL
        PTS(J, 1).Resize(1, 5).Value = TL 'renvoie le tableau TL dans la cellule ligne J colonne 1 de la plage PST redimensionnée
        TSD.ListRows.Add 'ajoute une ligne au tableau structuré TSD
        Set PTS = TSD.DataBodyRange 'redéfinit la plage PTS
    End If 'fin de la condition
Next I 'prochaine ligne de la boucle
Application.ScreenUpdating = True 'affiche les rafraîchissements d'écran
End Sub

 

[jo77]

Re

Voici le fichier modifié :

J'avais pas vu qu'il fallait comparer avec une cellule de référence


- A chaque lancement de la macro j'efface tout et je reconstruis tout

Il faut bien affecter la macro au bouton ou à la forme....


*Merci de ton retour

@Phil69970

Merci beaucoup Phil,

Cela fonctionne très bien.

J'avais tout de même une erreur que j'ai résolu.
La copie des lignes ne se faisait pas au bon endroit
Erreur : Les plages de destination étaient sous forme de tableau. Donc les lignes se copiaient en dessous du tableau. J'ai donc converti mon tableau en plage. Et cela a fonctionné.

Ensuite, pour que la macro fonctionne même sur une nouvelle feuille que je viendrais à dupliquer, j'ai remplacé le terme "Feuil13" par Active.Sheet

Voili Voilou.

Merci à Robert et toi pour vos solutions