Copie ligne dans une autre Feuille si date + 3 mois
Bonjour à tous,
Une dernière pour la route
Quelqu'un sait il comment je peux faire pour copier une ligne dans une autre feuille si :
- La date en Colonne S est dépassé depuis plus de 3 mois et si la valeur dans la colonne D est "En cours" Ou "Shooté"
Big Thanks
Mehdi
Salut Gmb,
Je vois que tu es matinal
Sur ton tableau c'est parfait, par contre sur la mienne je bloque sur cette fonction :
f.Range("A2").Resize(UBound(tabloR, 2), 19) = Application.Transpose(tabloR)
et je ne comprends pas pourquoi.
Cordialement,
Mehdi
Je te forward le fichier comme ça dessolé sans données.
Et que veux-tu que je fasse d'un fichier vide ?
Bye !
Désolé
Bonjour,
A tester.
A l'ouverture du classeur, les données sont copiées si les conditions sont requises.
Cdlt.
Bonjour et merci Jean-Eric, je regarde cela.
Bonjour à tous,
Désolé pour ma réponse tardive, voici ce que j'ai intégré pour que cela fonctionne :
Option Explicit
Sub micro()
Call ActiverDésactiverEvenement(False)
Dim lo As ListObject, lo2 As ListObject
Dim feuildetravail As Worksheet, feuildedonnées As Worksheet
Dim Cell As Range, rCell As Range
Dim lRow As Long
With ThisWorkbook
Set feuildedonnées = Worksheets("affaires") 'renommer les feuilles ICI
Set feuildetravail = Worksheets("+3mois") 'renommer les feuilles ICI
Set lo = feuildedonnées.ListObjects(1)
Set lo2 = feuildetravail.ListObjects(1)
End With
With feuildedonnées
.Activate
.Cells(1).Select
End With
Call DeleteListRow(lo2)
For Each Cell In lo.ListColumns(19).DataBodyRange
If Not IsEmpty(Cell) And IsDate(Cell) Then
If VBA.Date - Cell.Value > 90 Then
Select Case Cell.Offset(, -15)
Case "En cours", "Shooté":
With lo2
If .InsertRowRange Is Nothing Then
Set rCell = .HeaderRowRange.Cells(1).Offset(.ListRows.Count + 1)
Else
Set rCell = .InsertRowRange.Cells(1)
End If
End With
lRow = Cell.Row - lo.HeaderRowRange.Row
lo.ListRows(lRow).Range.Copy
rCell.PasteSpecial xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
Case Else
End Select
End If
End If
Next Cell
With feuildetravail
.Activate
.Cells(1).Select
End With
Call ActiverDésactiverEvenement(True)
End Sub
Sub DeleteListRow(lo2)
Dim iRowNumber As Integer
Dim objListRows As ListRows
Set objListRows = lo2.ListRows
For iRowNumber = objListRows.Count To 1 Step -1
objListRows(iRowNumber).Delete
Next iRowNumber
End Sub
Public Sub ActiverDésactiverEvenement(Vérité As Boolean) '-
Application.EnableEvents = Vérité '-
Application.ScreenUpdating = Vérité '-
End Sub