copier automatiquement des information selon une contrainte

[306255]

Bonjour à tous

je souhaite exporter de l'onglet résultat vers l'onglet dépôt de chèques, uniquement les données dont la colonne D est égal à CHQ.

Cet export se fera quand je cliquerais sur le bouton "générer le borderau"

Merci d'avance

 

[mapomme]

Re : copier automatiquement des information selon une contrainte

Bonjour 306255,

Un essai dans le fichier joint. Les lignes transférées sont marquées "CHQ-" pour éviter de les transférer deux fois. La MFC de la colonne D du tableau dans la feuille "résultat" a été modifiée en conséquence. Le code est dans module1:

Un gros hic dans cette version v1. Je n'avais pas fais remarqué que les cellules indiquant le mode de paiement intervenaient dans les calculs d’autres cellules.

Voir versions corrigées dans le message suivant ICI.

 

[mapomme]

Re : copier automatiquement des information selon une contrainte

re,

Un gros hic dans la version v1. Je n'avais pas remarqué que les cellules indiquant le mode de paiement intervenaient dans les calculs d’autres cellules. Voici deux versions corrigées: l’une (v3a) utilisant une colonne insérée avant la colonne D, l’autre utilisant un changement de couleur de police.

v3a -> code:

Sub Transferer()
Dim xrg As Range, xcell As Range, xvers As Range

Application.ScreenUpdating = False
With Sheets("résultat")
   Set xrg = Intersect(.Range("d7:d" & .Rows.Count), .UsedRange)
   For Each xcell In xrg
      If xcell = "CHQ" And LCase(xcell.Offset(, 1)) <> "x" Then
         Set xvers = Sheets("depot chèques").Cells(Rows.Count, "b").End(xlUp).Offset(1)
         xvers.Resize(, 4).Value = xcell.Offset(, -3).Resize(, 4).Value
         xvers.Offset(, 4).Resize(, 3).Value = xcell.Offset(, 2).Resize(, 3).Value
         xcell.Offset(, 1) = "x"
      End If
   Next xcell
End With
MsgBox "Transfert terminé !"
Application.ScreenUpdating = True
End Sub

v3b -> code:

Sub Transferer()
Dim xrg As Range, xcell As Range, xvers As Range

Application.ScreenUpdating = False
With Sheets("résultat")
   Set xrg = Intersect(.Range("d7:d" & .Rows.Count), .UsedRange)
   For Each xcell In xrg
      If xcell = "CHQ" And xcell.Font.Color <> RGB(0, 0, 125) Then
         Set xvers = Sheets("depot chèques").Cells(Rows.Count, "b").End(xlUp).Offset(1)
         xvers.Resize(, 7).Value = xcell.Offset(, -3).Resize(, 7).Value
         xcell.Font.Color = RGB(0, 0, 125)
      End If
   Next xcell
End With
MsgBox "Transfert terminé !"
Application.ScreenUpdating = True
End Sub