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