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...
BonjourBonsoir à toutes et à tous, bonsoir @Seddiki_adz
Amicalement
- Est-ce-que la Feuil1 est bien la feuille source
- Est-ce-que la Feuil2 est bien la feuille cible
- 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 ?
Alain
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
SuperRe,
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 :
Enrichi (BBcode):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
bonsoir mes excusesBonsoir @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