XL 2019 Copier des lignes les unes a la suite des autres dans une autre feuille sous conditions et seulement certaines colonnes

[MGH]

Bonjour,

Voilà mon problème:
J'ai un tableau de suivi des arrêts maladie, je voudrais pouvoir copier une ligne de mon tableau "Arrêts" sous la condition que la colonne AG soit "OUI", mais je ne veux pas copier toute les colonne seulement les colonne A-B, E-F, I, L, N, O-R, V-Z, AI et AJ dans une autre feuille excel "Subro". j'ai bien essayer avec çà =SI(ET(Arrêts!AG6="OUI";Arrêts!A6<>"");Arrêts!A6;""), cela copy bien mes informations mais les lignes ne se suivent pas et me laisse des trous. Je voudrais que mes données se suivent. Donc je me demandait si il y avait un code VBA qui me permettrait de faire cela?
Je remercie d'avance l'aide que vous pourriez m'apporter.

Je joint mon fichier

 

[wDog66]

Bonjour et bienvenue

Voici une procédure que vous pouvez utiliser

Sub CopierArretSubro(Lig As Long)
  Dim dLigS As Long
  Dim sRng As String
  ' Plage à copier avec # qui sera remplacé par le numéro de ligne
  sRng = "A#:B#,E#:F#,I#,L#,N#,O#:R#,V#:Z#,AI#,AJ#"
  sRng = Replace(sRng, "#", Lig)
  '
  With ThisWorkbook
    .Sheets("Arrêts").Range(sRng).Copy
    With .Sheets("Subro")
      dLigS = .Range("A" & Rows.Count).End(xlUp).Row
      If dLigS = 3 Then dLigS = 2   ' Commencer sur la première ligne
      With .Range("A" & dLigS + 1)
        .PasteSpecial Paste:=xlPasteValues
        .PasteSpecial Paste:=xlPasteFormats
      End With
    End With
  End With
End Sub

Vous l'appelez soit avec l'évènement Change de la feuille "Arrêts", soit avec une autre procédure et une boucle

' Pour la première ligne du tableau
Call CopierArretSubro(6)

A+

 

[MGH]

Bonjour et bienvenue

Voici une procédure que vous pouvez utiliser

Sub CopierArretSubro(Lig As Long)
  Dim dLigS As Long
  Dim sRng As String
  ' Plage à copier avec # qui sera remplacé par le numéro de ligne
  sRng = "A#:B#,E#:F#,I#,L#,N#,O#:R#,V#:Z#,AI#,AJ#"
  sRng = Replace(sRng, "#", Lig)
  '
  With ThisWorkbook
    .Sheets("Arrêts").Range(sRng).Copy
    With .Sheets("Subro")
      dLigS = .Range("A" & Rows.Count).End(xlUp).Row
      If dLigS = 3 Then dLigS = 2   ' Commencer sur la première ligne
      With .Range("A" & dLigS + 1)
        .PasteSpecial Paste:=xlPasteValues
        .PasteSpecial Paste:=xlPasteFormats
      End With
    End With
  End With
End Sub

Vous l'appelez soit avec l'évènement Change de la feuille "Arrêts", soit avec une autre procédure et une boucle

' Pour la première ligne du tableau
Call CopierArretSubro(6)

A+

Je te remercie pour ta réponse.
Si je devais mettre une condition pour la copie des lignes, je la mettrai où dans ton code? Car quand j'essaye le code il veut absolument que je l'assigne a un macro alors que je voudrais qu'il le fasse quand la cellule AG change pour "OUI".
Et si le choix de la cellule AG est fait par erreur sur "OUI" que la ligne soit supprimer sur la feuille "SUBRO"
C'est a dire que les lignes ne se copy sur la feuille Subro si et seulement si il y a "OUI" dans la cellule AG

 

[wDog66]

Bonjour MGH,

Alors dans le code de la feuille "Arrêts", tu mets ceci

Private Sub Worksheet_Change(ByVal Target As Range)
  ' Si modification dans la colonne AG
  If Not Intersect(Target, Range("AG:AG")) Is Nothing Then
    If UCase(Target.Value) = "OUI" Then
      Call CopierArretSubro(Target.Row)
    End If
  End If
End Sub

Dans un module tu mets le 1er code donné en #2

Arf, je viens de m'apercevoir qu'il y a une formule dans les cellules AG

=@SI.CONDITIONS(F6="";"";F6=">=1an";"OUI";F6="<1an";"NON")

Donc l'évènement Change ne fonctionnera pas sauf à faire F2 puis Entrée sur la cellule souhaitée...

A+

 

[MGH]

Bonjour wDog66

Quand j'écris les codes il me demande de l'assigner a un macro. Je suis un peu perdu!
La condition de la cellule AG a effectivement une formule qui va mettre "OUI" ou "NON" selon certaine conditions.
Je ne sais plus par quel bout prendre ces codes...
Es ce que ce serait plus simple de juste copier toute les colonnes puis masquer les colonnes que j'ai pas besoin sur mon tableau Subro? Et si je masque, es ce qu'a chaque fois qu'une ligne va se copier les colonnes masquer vont se démasquer?
Je suis bloquer sur ce tableau depuis 2 mois, j'ai vu pleins de code mais aucun ne fait exactement ce que je veux qui est de copier juste quelques colonne suite a la condition d'une colonne qui a une formule dedans.
Je te remercie de l'aide.

 

[wDog66]

Salut MGH

Es ce que ce serait plus simple de juste copier toute les colonnes puis masquer les colonnes que j'ai pas besoin sur mon tableau Subro? Et si je masque, es ce qu'a chaque fois qu'une ligne va se copier les colonnes masquer vont se démasquer?

Le plus simple serait effectivement d'avoir toutes les colonnes dans la feuille "Subro" et de masquer les colonnes inutiles, mais cela peut alourdir le fichier

Sinon, non, si tu masques les colonnes elles ne vont pas se réafficher si tu colles une ligne

Tu peux aussi utiliser ce code modifié, il suffit de créer un bouton avec une forme dans la feuille arrêt et de lui attribuer cette macro

Sub CopierArretSubro()
  Dim dLigA As Long, dLigS As Long
  Dim sRng As String
  Dim Wbk As Workbook, ShtArt As Worksheet, Cel As Range
  Dim Lo As ListObject
  ' Plage à copier avec # qui sera remplacé par le numéro de ligne
  sRng = "A#:B#,E#:F#,I#,L#,N#,O#:R#,V#:Z#,AI#,AJ#"
  Set Wbk = ThisWorkbook
  Set ShtArt = Wbk.Sheets("Arrêts")
  Set Lo = ShtArt.ListObjects("SuiviArrêts")
  For Each Cel In Lo.ListColumns("SUBRO OUI/NON?").DataBodyRange
    If UCase(Cel) = "OUI" Then
      ' Définir les plages à copier avec la ligne
      sRng = Replace(sRng, "#", Cel.Row)
      Wbk.Sheets("Arrêts").Range(sRng).Copy
      With Wbk.Sheets("Subro")
        dLigS = .Range("A" & Rows.Count).End(xlUp).Row
        If dLigS = 3 Then dLigS = 2   ' Commencer sur la première ligne
        With .Range("A" & dLigS + 1)
          .PasteSpecial Paste:=xlPasteValues
          .PasteSpecial Paste:=xlPasteFormats
        End With
      End With
    End If
  Next Cel
End Sub

Ceci dit, si c'est juste pour avoir une lecture des SUBRO, Power Query serait encore plus simple à utiliser

A+

 

[MGH]

Salut MGH

Le plus simple serait effectivement d'avoir toutes les colonnes dans la feuille "Subro" et de masquer les colonnes inutiles, mais cela peut alourdir le fichier

Sinon, non, si tu masques les colonnes elles ne vont pas se réafficher si tu colles une ligne

Tu peux aussi utiliser ce code modifié, il suffit de créer un bouton avec une forme dans la feuille arrêt et de lui attribuer cette macro

Sub CopierArretSubro()
  Dim dLigA As Long, dLigS As Long
  Dim sRng As String
  Dim Wbk As Workbook, ShtArt As Worksheet, Cel As Range
  Dim Lo As ListObject
  ' Plage à copier avec # qui sera remplacé par le numéro de ligne
  sRng = "A#:B#,E#:F#,I#,L#,N#,O#:R#,V#:Z#,AI#,AJ#"
  Set Wbk = ThisWorkbook
  Set ShtArt = Wbk.Sheets("Arrêts")
  Set Lo = ShtArt.ListObjects("SuiviArrêts")
  For Each Cel In Lo.ListColumns("SUBRO OUI/NON?").DataBodyRange
    If UCase(Cel) = "OUI" Then
      ' Définir les plages à copier avec la ligne
      sRng = Replace(sRng, "#", Cel.Row)
      Wbk.Sheets("Arrêts").Range(sRng).Copy
      With Wbk.Sheets("Subro")
        dLigS = .Range("A" & Rows.Count).End(xlUp).Row
        If dLigS = 3 Then dLigS = 2   ' Commencer sur la première ligne
        With .Range("A" & dLigS + 1)
          .PasteSpecial Paste:=xlPasteValues
          .PasteSpecial Paste:=xlPasteFormats
        End With
      End With
    End If
  Next Cel
End Sub

Ceci dit, si c'est juste pour avoir une lecture des SUBRO, Power Query serait encore plus simple à utiliser

A+

Bonjour,

Je te remercie le code marche très bien pour copier coller les colonnes que je veux mais par contre cela ne me copie que la première ligne, en autant de fois qu'il y a un "oui" dans ma colonne de sélection (SUBRO OUI/NON?).
J'ai essayé de modifier mais je n'y arrive vraiment pas car je ne comprend pas bien ou viens le problème: es ce que ce serait a partir de là que je dois faire les modifs pour que cela me copie toute les lignes?
dLigS = .Range("A" & Rows.Count).End(xlUp).Row
With .Range("A" & dLigS + 1)
.PasteSpecial Paste:=xlPasteValues
.PasteSpecial Paste:=xlPasteFormats

Et y aurait il un autre moyen de faire le copier coller sans avoir de bouton, mais qu'il le fasse automatiquement lorsqu'il y a un OUI dans la colonne "AG"?

​

​

 

[MGH]

Bonjour,

J'ai donc decider de changer mon code car je n'arrivais pas a faire marcher celui de dessus comme je le voulais. J'ai aussi changer le nombre de colonne a copier et je ne vais copier que la preier colonne selon la condition de ma cellule colonne "AF" (qui est le resultat d'une formule), Donc si "OUI" dans cette colonne la colonne A va se copier dans la feuille Subro.
Donc voici mon code. 2 problemes: La premier ligne ne veut pas s'écrire dans mon tableau, deuxiemement quand j'apppuis sur mon bouton pour la mise a jour, il me remet toute les données au lieu de juste faire une mise a jour des données rajouter. Es ce que quelqu'un peut m'aider?

Sub CopierArretSubro()

Dim ws_1 As Worksheet
Dim ws_2 As Worksheet
Dim der_ligne_Feuil1 As Long, der_ligne_Feuil2 As Long
Dim ligne_coller As Long
Dim destination As Long

'Définir mes feuilles
Set ws_Feuil1 = Worksheets("ARRÊTS")
Set ws_Feuil2 = Worksheets("SUIVI IJ CPAM")

'Identifier derniére ligne colonne A feuil 1
der_ligne_Feuil1 = ws_Feuil1.Cells(Rows.Count, 1).End(xlUp).Row

'boucle
For I = 6 To der_ligne_Feuil1

'Identifier le statut de la cell AF , et si oui copier coller en feuil 2
If ws_Feuil1.Cells(I, 32) = "OUI" Then
'Identifier derniére ligne colonne A feuil 2
der_ligne_Feuil2 = ws_Feuil2.Cells(Rows.Count, 1).End(xlUp).Row
ligne_coller = der_ligne_Feuil2 + 1

'coller la cellule à la suite sur la feuille 2
ws_Feuil2.Cells(ligne_coller, 1) = ws_Feuil1.Cells(I, 1)
End If
Next

End Sub