XL 2016 Code Transfer suivant condition

[Seddiki_adz]

bonjour
pour transférer en fonction de la colonne T , les colonnes: F, G,M,O,P,L de la basse feuil1 vers les colonnes B,C,D,E,F,G par cette ordre
j'ai besoin d'aide pour rectifier ce code
Merci

 

[AtTheOne]

Bonsoir à toutes et à tous, bonsoir @Seddiki_adz

1. Est-ce-que la Feuil1 est bien la feuille source
2. Est-ce-que la Feuil2 est bien la feuille cible
3. Est-ce qu'il faut demander le critère à l'utilisateur (Ici la seule valeur est CEM2) ou peut-on faire la sélection par un double clic sur une cellule du tableau puis utiliser la valeur de la colonne T comme critère ?

Amicalement
Alain

 

[Seddiki_adz]

Bonsoir à toutes et à tous, bonsoir @Seddiki_adz

1. Est-ce-que la Feuil1 est bien la feuille source
2. Est-ce-que la Feuil2 est bien la feuille cible
3. Est-ce qu'il faut demander le critère à l'utilisateur (Ici la seule valeur est CEM2) ou peut-on faire la sélection par un double clic sur une cellule du tableau puis utiliser la valeur de la colonne T comme critère ?

Amicalement
Alain

Bonjour
Bonne retour
oui
la Feuil1 est bien la feuille source
la Feuil2 est bien la feuille cible
le critère la colonne T

 

[AtTheOne]

Re,
Voici un exemple de ce que l'on peut faire.
J'ai transformé tes listes en Feuil1 et Feuil2 en tableaux structurés.
J'ai géré l'événement BeforeDoubleClick de la Feuil1 de telle sorte que, si l'on fait un double clic dans la colonne T (ou 20), les cellules F, G, M, O, P ,L des lignes qui ont le même code en T soient transférées vers la Feuil2.
Voilà le code :

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Dim Critère As String, TbRes(), tb, moins As Byte, i As Long, j As Long
    If Not Intersect(Target, Me.[tb_Source[20]]) Is Nothing Then
        Critère = Intersect(Target, Me.[tb_Source[20]]).Value
        tb = Me.[tb_Source]
        j = 0
        For i = 1 To UBound(tb)
            If tb(i, 20) = Critère Then
                j = j + 1: ReDim Preserve TbRes(1 To 6, 1 To j)
                TbRes(1, j) = tb(i, 6): TbRes(2, j) = tb(i, 7): TbRes(3, j) = tb(i, 13): TbRes(4, j) = tb(i, 15): TbRes(5, j) = tb(i, 16): TbRes(6, j) = tb(i, 12)
            End If
        Next i
        If j > 0 Then
            With Feuil2.[tb_Cible]
                moins = 0
                If WorksheetFunction.CountA(.Rows(1)) = 1 Then moins = 1
                .Offset(.Rows.Count - moins, 1).Resize(j, 6).Value = Application.Transpose(TbRes)
            End With
            Cancel = True
            MsgBox j & " ligne(s) transférée(s)"
        End If
    End If
End Sub

Voir PJ
Amicalement
Alain

 

[Seddiki_adz]

Re,
Voici un exemple de ce que l'on peut faire.
J'ai transformé tes listes en Feuil1 et Feuil2 en tableaux structurés.
J'ai géré l'événement BeforeDoubleClick de la Feuil1 de telle sorte que, si l'on fait un double clic dans la colonne T (ou 20), les cellules F, G, M, O, P ,L des lignes qui ont le même code en T soient transférées vers la Feuil2.
Voilà le code :

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Dim Critère As String, TbRes(), tb, moins As Byte, i As Long, j As Long
    If Not Intersect(Target, Me.[tb_Source[20]]) Is Nothing Then
        Critère = Intersect(Target, Me.[tb_Source[20]]).Value
        tb = Me.[tb_Source]
        j = 0
        For i = 1 To UBound(tb)
            If tb(i, 20) = Critère Then
                j = j + 1: ReDim Preserve TbRes(1 To 6, 1 To j)
                TbRes(1, j) = tb(i, 6): TbRes(2, j) = tb(i, 7): TbRes(3, j) = tb(i, 13): TbRes(4, j) = tb(i, 15): TbRes(5, j) = tb(i, 16): TbRes(6, j) = tb(i, 12)
            End If
        Next i
        If j > 0 Then
            With Feuil2.[tb_Cible]
                moins = 0
                If WorksheetFunction.CountA(.Rows(1)) = 1 Then moins = 1
                .Offset(.Rows.Count - moins, 1).Resize(j, 6).Value = Application.Transpose(TbRes)
            End With
            Cancel = True
            MsgBox j & " ligne(s) transférée(s)"
        End If
    End If
End Sub

Voir PJ
Amicalement
Alain

Super
mon dieu merci
mes sollicitation

 

[AtTheOne]

Bonsoir @Seddiki_adz
Merci pour le retour.
Pour la solution, tu t'es trompé de post, c'est le #4 qu'il faut marquer ...
A bientôt
Alain

 

[Seddiki_adz]

Bonsoir @Seddiki_adz
Merci pour le retour.
Pour la solution, tu t'es trompé de post, c'est le #4 qu'il faut marquer ...
A bientôt
Alain

bonsoir mes excuses
A bientôt