Gestion de ronde parking / Insertion de date + copie /intégration de lignes

Y compris Power BI, Power Query et toute autre question en lien avec Excel
Avatar du membre
James007
Fanatique d'Excel
Fanatique d'Excel
Messages : 12'007
Appréciations reçues : 412
Inscrit le : 30 août 2014
Version d'Excel : 2007 EN

Message par James007 » 24 mai 2019, 10:25

Star-Lord a écrit :
24 mai 2019, 09:45
Bonjour,

Oui cela me copie les lignes de la ronde du 08/04 en boucle jusqu'à la date de fin.
Bonjour,

Pas tout à fait ...

Avant de lancer la macro ...

1. dans la feuille, avoir une journée complète avec toutes les immats ...
2. dans la cellule F1 ... il faut saisir la date de fin du planning ...
3. ensuite, on peut lancer la macro ...
A+

:)

Quand on n’a qu’un marteau, tous les problèmes deviennent des clous…
Avatar du membre
Klin89
Membre dévoué
Membre dévoué
Messages : 596
Appréciations reçues : 21
Inscrit le : 28 mai 2011
Version d'Excel : 2003 FR

Message par Klin89 » 26 mai 2019, 20:45

Bonsoir James007, Star-Lord :)

C'est ce résultat là que tu souhaites obtenir :
Un peu lent à cause du "ReDim Preserve"
Option Explicit
Sub test()
Dim a, e, i As Long, ii As Long, iii As Long, n As Long
Dim dateMin As Long, dateMax As Long, dico As Object
    Set dico = CreateObject("Scripting.Dictionary")
    Application.ScreenUpdating = False
    With Sheets("Ronde").Range("a1").CurrentRegion
        a = .Value2
        dateMin = a(2, 1): dateMax = a(UBound(a), 1)
        For i = dateMin To dateMax
            dico(i) = Empty
        Next
        For i = 2 To UBound(a, 1)
            If IsEmpty(dico(a(i, 1))) Then
                ReDim w(1 To UBound(a, 2), 1 To 1)
            Else
                w = dico(a(i, 1))
                ReDim Preserve w(1 To UBound(w, 1), 1 To UBound(w, 2) + 1)
            End If
            For ii = 1 To UBound(a, 2)
                w(ii, UBound(w, 2)) = a(i, ii)
            Next
            dico(a(i, 1)) = w
        Next
        For i = 0 To dico.Count - 1
            If IsEmpty(dico.Items()(i)) Then
                ReDim w(1 To UBound(dico.Items()(i - 1), 1), 1 To UBound(dico.Items()(i - 1), 2))
                For ii = 1 To UBound(dico.Items()(i - 1), 2)
                    w(1, ii) = dico.keys()(i)
                Next
                For ii = 2 To UBound(dico.Items()(i - 1), 1)
                    For iii = 1 To UBound(dico.Items()(i - 1), 2)
                        w(ii, iii) = dico.Items()(i - 1)(ii, iii)
                    Next
                Next
                dico.Item(dico.keys()(i)) = w
            End If
        Next
        With .Offset(, .Columns.Count + 3)
            .CurrentRegion.Clear
            .Resize(1) = Array("Date", "N° Véhicule", "N° Place", "Nom de l'agent")
            n = 2
            For Each e In dico.keys
                With .Cells(n, 1).Resize(UBound(dico(e), 2), UBound(dico(e), 1))
                    .Value = Application.Transpose(dico(e))
                    .BorderAround Weight:=xlThin
                End With
                n = n + UBound(dico(e), 2)
            Next
            With .CurrentRegion
                .Rows(1).Interior.ColorIndex = 43
                .HorizontalAlignment = xlCenter
                .BorderAround Weight:=xlThin
                .Borders(xlInsideVertical).Weight = xlThin
                .VerticalAlignment = xlCenter
                .Font.Name = "Calibri"
                .Font.Size = 10
                .Columns(1).NumberFormat = "m/d/yyyy"
                .Columns.AutoFit
            End With
        End With
    End With
    Set dico = Nothing
    Application.ScreenUpdating = True
End Sub
klin89
Avatar du membre
Jean-Eric
Fanatique d'Excel
Fanatique d'Excel
Messages : 15'338
Appréciations reçues : 532
Inscrit le : 27 août 2012
Version d'Excel : 365 32 bits

Message par Jean-Eric » 26 mai 2019, 21:58

Bonjour,
Une proposition à étudier.
Réalisé avec Power Query.
VBA est juste utilisé pour l'actualisation.
Cdlt.
Test Parking.xlsm
(117.24 Kio) Téléchargé 3 fois
Jean-Eric

Je ne réponds pas aux M.P. non sollicités.
Répondre Sujet précédentSujet suivant
  • Sujets similaires
    Réponses
    Vues
    Dernier message