Au secours ! Comparer les dates et copier les lignes

jeveuxréussir Messages postés 20 Statut Membre -  
Diablo76 Messages postés 275 Date d'inscription   Statut Membre Dernière intervention   -

Bonjour,

J'ai un ficiher Excel pour gérer les véhicules . Ce fichier contient trois onglets :

-Onglet Parc: qui contient la liste des véhicules

- Onglet Tableau Rapport : dans lequel, je choisi la période

- Onglet Rapport : Dans lequel, j'obtiens le résultat de mon rapport.

La cas d'usage est le suivant :

L'utilisatateur se place dans l'onglet "Tableau Rapport" et sélectionne une période (Date Début et Date Fin) et clique sur le bouton "Exécuter rapport".

Je souhaite que toutes les lignes avec dans l'onglet "Parc" dont les dates dans la colonne"B" qui sont comprises entre les (Date Début et Date Fin) soient copier dans l'onglet "Rapport".

Vous trouverez ci-joint le lien vers le fichier. Si le lien ne marche pas, copier et coller dans le navigateur.

https://cijoint.org/r/usb538M8#c6CcYJDkAPOCEQ7ziufJv2eBiQkvrCA/lWL8XkQgZLU

Merci beaucoup pour votre aide précieuse !

A voir également:

1 réponse

Diablo76 Messages postés 275 Date d'inscription   Statut Membre Dernière intervention   94
 

Salut,

Voilà un script VBA qui devrait te convenir :

Sub rapport_Parc_Auto()

    Dim wsParc As Worksheet
    Dim wsRapport As Worksheet
    Dim wsTableau As Worksheet
    Dim dateDebut As Date
    Dim dateFin As Date
    Dim lastRow As Long
    Dim lastCol As Long
    Dim i As Long
    Dim ligneDest As Long
    Dim dateParc As Date

    ' Désactivation de l'affichage
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.DisplayAlerts = False

    ' Définition des feuilles
    Set wsParc = ThisWorkbook.Sheets("Parc")
    Set wsRapport = ThisWorkbook.Sheets("Rapport")
    Set wsTableau = ThisWorkbook.Sheets("Tableau_Rapport")

    ' Récupération des dates
    If IsDate(wsTableau.Range("C4").Value) And IsDate(wsTableau.Range("D4").Value) Then
        dateDebut = wsTableau.Range("C4").Value
        dateFin = wsTableau.Range("D4").Value
    Else
        MsgBox "Merci de saisir des dates valides dans les cellules C4 et D4.", vbExclamation
        GoTo Fin
    End If

    ' Vérification de cohérence
    If dateDebut > dateFin Then
        MsgBox "La date de début ne peut pas être postérieure à la date de fin.", vbCritical
        GoTo Fin
    End If

    ' Nettoyage de la feuille Rapport
    wsRapport.Cells.Clear

    ' Trouver la dernière colonne utilisée sur Parc
    lastCol = wsParc.Cells(1, wsParc.Columns.Count).End(xlToLeft).Column

    ' Copier les en-têtes avec mise en forme
    wsParc.Range(wsParc.Cells(1, 1), wsParc.Cells(1, lastCol)).Copy
    wsRapport.Cells(1, 1).PasteSpecial xlPasteAll

    ligneDest = 2
    lastRow = wsParc.Cells(wsParc.Rows.Count, "B").End(xlUp).Row

    ' Copier les lignes correspondantes avec mise en forme
    For i = 2 To lastRow
        If IsDate(wsParc.Cells(i, "B").Value) Then
            dateParc = wsParc.Cells(i, "B").Value
            If dateParc >= dateDebut And dateParc <= dateFin Then
                wsParc.Rows(i).Copy
                wsRapport.Rows(ligneDest).PasteSpecial xlPasteAll
                ligneDest = ligneDest + 1
            End If
        End If
    Next i

    ' Tri automatique par la colonne B (date)
    If ligneDest > 2 Then
        wsRapport.Sort.SortFields.Clear
        wsRapport.Sort.SortFields.Add Key:=wsRapport.Range("B2:B" & ligneDest - 1), _
            SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With wsRapport.Sort
            .SetRange wsRapport.Range("A1").CurrentRegion
            .Header = xlYes
            .Apply
        End With
    End If
    
    MsgBox "Rapport généré avec succès entre le " & Format(dateDebut, "dd/mm/yyyy") & _
           " et le " & Format(dateFin, "dd/mm/yyyy") & ".", vbInformation
    
    'Focus sur la feuille Rapport
    wsRapport.Activate
    wsRapport.Range("A1").Select

    ' Réactivation de l'affichage avant le message
    Application.ScreenUpdating = True

    

Fin:
    ' Réactivation de l'affichage
    Application.CutCopyMode = False
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    Application.ScreenUpdating = True

End Sub



1