Copier/coller des lignes de tableau et plus si affinités

---- j'ai ré-édité ma demande dans un nouveau sujet, en reformulant plus clairement mes idées et mon fichier d'exemple ---

Bonjour,

j'ai un code très efficace qui m'a été proposé par les pro du forum qui me permet de copier/coller des lignes entières d'un tableau (sélectionnées selon critère) vers un autre tableau.

Je souhaiterai améliorer ce code pour que lors du collage, soient ajoutées des cellules.

Par exemple je copie une ligne entière du Tableau4 : deux cellules :

"AA" "BB"

J'aimerai que le collage sur le Tableau15 soit :

"AA" "BB" "CC"

où "CC" serait par exemple la date du jour ou bien la valeur de la variable nb_alea générée lors de l’exécution du code.

Qu'en pensez-vous ?

Pour faire fonctionner le code, il faut sélectionner un fournisseur du Tableau5 (feuille "COMMANDE") et cliquer sur "Envoyer la commande fournisseur".

L'ensemble des lignes du Tableau4 (feuille "COMMANDE") correspondant au fournisseur sélectionné est alors copié vers le Tableau15 (feuille "GLOBAL"), et ensuite supprimé de la feuille "COMMANDE".

En l'occurrence, dans ce projet excel, le code copie les colonnes A à L du Tableau4 vers le Tableau15, et j'aimerai que lors du collage sur le Tableau15 les colonnes M & N soient respectivement remplies par la date du jour & la valeur de nb_alea.

Sub Envoyer_commande()
Randomize
nb_alea = Int(1000 * Rnd) + 1
Set isect = Application.Intersect(ActiveCell, Range("G3:G10"))
If Not isect Is Nothing And ActiveCell <> "" Then
FOURNISSEUR = ActiveCell.Value
If MsgBox("Êtes-vous sûr de vouloir lancer la commande des produits" & " " & _
FOURNISSEUR & " " & "?", vbYesNo, "Demande de confirmation") = vbYes Then

Call Archiver1

End If
End If
End Sub

Sub Archiver1()
Dim ACell As Range, n As Long, i As Long
    Application.ScreenUpdating = False
    Set ACell = ActiveCell
    If ACell.ListObject Is Nothing Then Exit Sub
    If ACell.ListObject.Name = "Tableau5" And Len(ACell) > 0 Then
        With ActiveSheet.ListObjects("Tableau4")
            n = .ListRows.Count
            For i = n To 1 Step -1
                If .ListColumns("FOURNISSEUR").DataBodyRange.Rows(i).Value = ACell.Value Then
                    Range("Tableau4[[#Headers],[DATE]:[SPECIALITE]]").Offset(i, 0).Copy
                    Sheets("GLOBAL").Select
                    Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Select
                    Sheets("GLOBAL").Paste
                    Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Select
                    .ListRows(i).Delete
                End If
            Next i
        End With
    End If
    Sheets("COMMANDE").Select
End Sub

Salut Samzou974,

tu m'excuseras, j'espère, d'avoir réalisé cela à ma sauce...

Ta procédure (unique) de commande démarre par un double-clic sur le fournisseur désigné dans ton petit tableau en [G3:G10].

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'
Dim iAlea%, iRow%
'
Cancel = True
If Not Intersect(Target, Range("G3:G10")) Is Nothing And Target <> "" Then
    On Error Resume Next
    If Columns(8).Find(what:=Target, lookat:=xlWhole).Row > 0 Then
        If MsgBox("Êtes-vous sûr de vouloir lancer la commande des produits " & _
        Target & " ?", vbYesNo, "Demande de confirmation") = vbYes Then
            Randomize
            iAlea = Int(1000 * Rnd) + 1
            With ActiveSheet.ListObjects("Tableau4")
                For i = .ListRows.Count To 1 Step -1
                    If .ListColumns("FOURNISSEUR").DataBodyRange.Rows(i).Value = Target Then
                        With Worksheets("GLOBAL")
                            iRow = .Range("A" & Rows.Count).End(xlUp).Row + 1
                            .Range("A" & iRow & ":L" & iRow).Value = Range("Tableau4[[#Headers],[DATE]:[PRIX]]").Offset(i, 0).Value
                            .Range("M" & iRow).Value = Format(Date, "[$-40C]dd mmmm yyyy")
                            .Range("N" & iRow).Value = iAlea
                        End With
                        Range("Tableau4[[#Headers],[DATE]:[PRIX]]").Offset(i, 0).Delete shift:=xlUp
                    End If
                Next i
            End With
        End If
    End If
    On Error GoTo 0
End If
'
End Sub

A+

Merci curulis57 =)

C'est exactement ce que je cherche.

Efficace dès le matin !

Bonne journée !