Macro recopie onglet 1 à onglet 2 si condition réunis

Bonsoir,

J’ai toutes les code pour les macros qui fonctionne sur le petit tableau du premier fichier… Je cherche à l’adapter maintenant sur un tableau de 26 colonnes enfin allant jusqu’à Z et de récupérer la donner L dans une autre colonne la (J) .

voici le code

Option Explicit

Dim fb As Worksheet, fc As Worksheet, tablo, tabloR()
Dim i&, j&, k&

Private Sub Worksheet_Activate()

Set fb = Sheets("fichier de base extrait")
Set fc = Sheets("fichier pour contrôle qualité")
tablo = fb.Range("A2:F" & fb.Range("A" & Rows.Count).End(xlUp).Row)
Application.ScreenUpdating = False

'On met dans une variable tableau les lignes dont le type article est "l"
k = 0
For i = 1 To UBound(tablo, 1)
    If UCase(tablo(i, 5)) = "L" Then
        ReDim Preserve tabloR(1 To 6, 1 To k + 1)
        For j = 1 To 6
            tabloR(j, k + 1) = tablo(i, j)
        Next j
        k = k + 1
    End If
Next i

'On écrit le résultat sur la feuille de destination
fc.Range("A1").CurrentRegion.Offset(1, 0).Clear
fc.Range("A2").Resize(UBound(tabloR, 2), 6) = Application.Transpose(tabloR)

'On classe les lignes selon les dates de la colonne F
fc.Range("A2:F" & fc.Range("A" & Rows.Count).End(xlUp).Row).Sort key1:=fc.Range("F2"), _
        order1:=xlAscending, Header:=xlNo

'On passe toutes les lignes pour mettre les couleurs
For i = 2 To Range("A" & Rows.Count).End(xlUp).Row
    If CDate(fc.Range("F" & i)) < Date Then
        fc.Range("A" & i & ":F" & i).Interior.Color = RGB(255, 0, 0)
        fc.Range("A" & i & ":F" & i).Font.Color = RGB(255, 255, 255)
    ElseIf CDate(fc.Range("F" & i)) - 2 >= Date Then
        fc.Range("A" & i & ":F" & i).Interior.Color = RGB(0, 255, 0)
    Else
        fc.Range("A" & i & ":F" & i).Interior.Color = RGB(255, 255, 0)
    End If
Next i

End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

If Not Intersect(Target, Range("A3:F" & Range("A" & Rows.Count).End(xlUp).Row)) Is Nothing Then
    Cancel = True
    Range("A" & Target.Row & ":F" & Target.Row).Interior.Color = RGB(204, 153, 255)
    Range("A" & Target.Row - 1 & ":F" & Target.Row - 1).Copy
    Range("A" & Target.Row + 1).Insert shift:=xlDown
    Range("A" & Target.Row - 1 & ":F" & Target.Row - 1).Delete shift:=xlUp
    
End If
Application.CutCopyMode = False

End Sub

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)

Application.ScreenUpdating = False
If Not Intersect(Target, Range("A2:F" & Range("A" & Rows.Count).End(xlUp).Row)) Is Nothing Then
    Range("A" & Target.Row & ":F" & Target.Row).Copy
    Range("A" & Target.Row + 2).Insert shift:=xlDown
    i = Target.Row
    Range("A" & Target.Row & ":F" & Target.Row).Delete shift:=xlUp
    
    
Exit Sub
    If CDate(fc.Range("F" & i + 1)) < Date Then
        fc.Range("A" & i & ":F" & i + 1).Interior.Color = RGB(255, 0, 0)
        fc.Range("A" & i + 1 & ":F" & i + 1).Font.Color = RGB(255, 255, 255)
    ElseIf CDate(fc.Range("F" & i + 1)) - 2 >= Date Then
        fc.Range("A" & i + 1 & ":F" & i + 1).Interior.Color = RGB(0, 255, 0)
    Else
        fc.Range("A" & i + 1 & ":F" & i + 1).Interior.Color = RGB(255, 255, 0)
    End If
    
End If

End Sub

Bonne soirée à tous

Bonjour
Quel est ton fichier?
Que fait ton code?

J’ai réussis à résoudre ce problème, mais un problème en apporte un autre. En faite si il trouve pas la valeur L dans la colonne V pour recopier sur le deuxième onglet Excel il envois un message d’erreur. Sa arrête la marcro. Et le 3eme onglet c’est pareil si Excel ne trouve pas le critère c’est tout sauf le L alors il met un message d’erreur.

Priorité Réception et Qualité Vers2 nu.xlsm (142,2 Ko)