Chronologisch overzicht

[DeVenter]

Hallo allemaal,

Ik maak dagelijks een planning voor de productie van orders op bepaalde productielijnen.
Iedere productielijn krijgt een lijstje met de eigen orders voor die dag.

Door kopieren, plakken speciaal en sorteren maak ik daar een chronologisch overzicht van wat onder andere in het magazijn gebruikt wordt.

Dat kopieren, plakken speciaal en sorteren heb ik in een macro gezet, maar nu ik deze site zie denk ik dat het maken van zo'n chronologisch overzicht mogelijk veel eenvoudiger en minder foutgevoelig kan door VBA te gebruiken.
Ik heb daar alleen niet veel ervaring mee.
Wie kan mij op weg helpen?
Het kopieren en plakken lukt wel. Het sorteren op datum en tijd, het negeren van de witregels en andere regels zonder tijden lukt me niet.

Alvast bedankt,
DeVenter

 

[Withaar]

Wat niet handig is, is kolom N, deze heeft geen kolom kop naam.
Als je gaat kopiëren en dan sorteren gaat dit problemen geven.

Als je toch niets wilt ziet gebruik dan een kolomkop naam die de zelfde kleur heeft als de achtergrond kleur van de cel.

Ga er even mee spelen.

 

[Demeter]

Probeer deze code eens:

Sub test()
Dim d As Range
Dim p As Long

Application.EnableEvents = False

Sheets("overzicht per lijn").Select

With ActiveSheet.Range("E2:E79")
    With ActiveSheet.Range("E2:E79")
        Set c = .Find("26", LookAt:=xlWhole)
        c.Select
        p = (c.Row() + 2)
            For Each d In Range("A" & p, "A" & (p + 12))
                If d.Offset(, 1).Text <> "" Then
                    d.Resize(, 17).Copy Sheets("chroverz").Range("A" & Sheets("chroverz").Range("A65536").End(xlUp).Row + 1)
                End If
            Next

        Set c = .Find("3", LookAt:=xlWhole)
        c.Select
        p = (c.Row() + 2)
            For Each d In Range("A" & p, "A" & (p + 12))
                If d.Offset(, 1).Text <> "" Then
                    d.Resize(, 17).Copy Sheets("chroverz").Range("A" & Sheets("chroverz").Range("A65536").End(xlUp).Row + 1)
                End If
            Next
 
        Set c = .Find("5", LookAt:=xlWhole)
        c.Select
        p = (c.Row() + 2)
            For Each d In Range("A" & p, "A" & (p + 12))
                If d.Offset(, 1).Text <> "" Then
                    d.Resize(, 17).Copy Sheets("chroverz").Range("A" & Sheets("chroverz").Range("A65536").End(xlUp).Row + 1)
                End If
            Next

        Set c = .Find("30", LookAt:=xlWhole)
        c.Select
        p = (c.Row() + 2)
            For Each d In Range("A" & p, "A" & (p + 12))
                If d.Offset(, 1).Text <> "" Then
                    d.Resize(, 17).Copy Sheets("chroverz").Range("A" & Sheets("chroverz").Range("A65536").End(xlUp).Row + 1)
                End If
            Next

        Set c = .Find("1", LookAt:=xlWhole)
        c.Select
        p = (c.Row() + 2)
            For Each d In Range("A" & p, "A" & (p + 12))
                If d.Offset(, 1).Text <> "" Then
                    d.Resize(, 17).Copy Sheets("chroverz").Range("A" & Sheets("chroverz").Range("A65536").End(xlUp).Row + 1)
                End If
            Next
    End With
End With

Sheets("chroverz").Select

Sheets("chroverz").Range("A4:Q" & Sheets("chroverz").Range("A65536").End(xlUp).Row).Select
Selection.Sort Key1:=Range("A4"), Order1:=xlAscending, Key2:=Range("B4"), Order2:=xlAscending, Key3:=Range("C4"), Order3:=xlAscending

Application.EnableEvents = True

End Sub

Misschien niet de meest elegante maar doet de klus .
Ga ik er wel vanuit dat je niet meer Lijnen krijgt en tevens de namen niet gaat veranderen.

Groet,
Ferenc

 

[Withaar]

Eerder bericht toch maar even verwijderd, in macro en tekst zaten te veel fouten, deze is volgens mij een stuk beter.

@Demeter, volgens mij is die van jou ook niet helemaal zonder fouten.
Sheets("overzichtperlijn").Select moet bv Sheets("overzicht per lijn").Select zijn.
Maar ook met name de sortering lijkt me niet helemaal zo al het zou moeten.
En je hardcoded oplossing om te zoeken op de lijnnummers lijkt me weinig flexibel.
Wel een fraaie code verder, zeker vergeleken met mijn monster... knip en plak werk en stuken macro recorder code... das nooit echt fraai, maar het werkt.

 

[Demeter]

Withaar,

Sheets("overzichtperlijn").Select moet bv Sheets("overzicht per lijn").Select zijn.

aangepast. liep een beetje te *****n met de tabnamen.
Sorteren komt direct uit de macrorecorder , mbv Data/sorteren ipv het toolbar icoontje en werkt voor mijn maatstaven ok.

Denk dat er bij jouw code redelijk wat uit kan. Maar het idee is geheel duidelijk.
Misschien moeten we ze bij elkaar gooien
Denk dat we moeten afwachten wat DeVenter met zijn file wil.

Bedankt voor je feedback over mijn code (dat is toch waar we het voor doen).


Groet,
Ferenc

 

[Withaar]

Demeter,

Ik ga toch ook nog eens met jou code aan het stoeien.
Bv Waarom heb je geen probleem met de lege kolom kop in kolom N?
En zou het ook niet zonder hardcoded lijnnummers kunnen...

Gewoon voor de lol

Bedankt voor je feedback over mijn code (dat is toch waar we het voor doen).

Yup, lijkt me toch logisch.

{Edit}
Bv Waarom heb je geen probleem met de lege kolom kop in kolom N?
Is me nu duidelijk... (range selecteren en optie sorteren gebruiken).
De beperking van 3 (per keer) lijkt me hier toch een probleem te geven.
Ik zou eerst sorteren op lijn, dan op eindtijd, dan op begin tijd en dan op datum, 4 sorteringen dus.

 

[Withaar]

Een hèèèèè`??? moment...

Kijk even mee,

Bovenaan het de orginele data uit het bestand (inclusies de verwachte sortering).
Midden data is gemaakt met de marco van Demeter.
Sortering leek me al niet helemaal juist.

Dus data gekopieerd en daarna 'sorteren' er op los gelaten.
En dit gaat helemaal tegen mijn gevoel in.
Er staat toch duidelijk Vervolgens op tussen de opties.
Zo als het nu is zou ik verwachten dat eerst kolom B gesorteerd wordt dan C en dan D, dus de D kolom zou eigenlijk van laag naar hoog moeten lopen... toch.
Maar het tegenovergestelde is waar.
Als laatste is over duidelijk de B kolom gesorteerd, datum range loopt netjes van ouder naar nieuwer.
N.b. de data uit de derde serie was hier geselecteerd.

Nu nog die hardcoded lijnnummers er uit...

{Edit}
Zie net dat er toch een verschil zit tussen de bron en het 'nieuwe' eindresultaat.
Rij 9 en 10 zou ik (en heb ik) omgedraaid d.w.z. eerder eindtijd eerder...
@DeVenter, foutje in de bron, of zie ik een ander sorteer veld over het hoofd?

 

[Withaar]

Nou, dit is het geworden.
Met grote dank aan Demeter voor de basis code wat mij betreft, maar e.a. bleek toch nog véél korter te kunnen, qua code (en mogelijk kan er nog wel wat uit...:evil: )

Sub test2()
Dim d As Range
Dim p As Long
Dim l As Long
Application.EnableEvents = False
Sheets("chroverz").Select
Sheets("chroverz").Range("A4:Q" & Sheets("chroverz").Range("A65536").End(xlUp).Row + 3).Select
Selection.ClearContents
Sheets("overzicht per lijn").Select
l = Range("A65536").End(xlUp).Row
With ActiveSheet.Range("F:F")
p = 1
For Each d In Range("A" & p, "A" & (p + l))
      If d.Offset(, 2).Text <> "" Then
            d.Resize(, 17).Copy Sheets("chroverz").Range("A" & Sheets("chroverz").Range("A65536").End(xlUp).Row + 4)
      End If
Next
End With
Sheets("chroverz").Select
Sheets("chroverz").Range("A4:Q" & Sheets("chroverz").Range("A65536").End(xlUp).Row).Select
Selection.Sort Key1:=Range("B4"), Order1:=xlAscending, Key2:=Range("C4"), Order2:=xlAscending, Key3:=Range("D4"), Order3:=xlAscending
Application.EnableEvents = True
Range("A1").Select
End Sub

Met nog maar 2 harde verwijzingen, de blad namen.

 

[Wigi]

(en mogelijk kan er nog wel wat uit...:evil: )

Idd

Sub test2()
    Dim d As Range, l As Long
    Application.EnableEvents = False
    Sheets("chroverz").Range("A4:Q" & Sheets("chroverz").Range("A" & Rows.Count).End(xlUp).Row + 3).ClearContents
    Sheets("overzicht per lijn").Select
    l = Sheets("overzicht per lijn").Range("A" & Rows.Count).End(xlUp).Row
    For Each d In Range("A1").Resize(2)
          If d.Offset(, 2) <> "" Then _
            d.Resize(, 17).Copy Sheets("chroverz").Range("A" & Sheets("chroverz").Range("A" & Rows.Count).End(xlUp).Row + 4)
    Next
    Sheets("chroverz").Range("A4:Q" & Sheets("chroverz").Range("A" & Rows.Count).End(xlUp).Row).Sort Key1:=Range("B4"), _
        Order1:=xlAscending, Key2:=Range("C4"), Order2:=xlAscending, Key3:=Range("D4"), Order3:=xlAscending
    Application.EnableEvents = True
End Sub

Ik heb het niet getest deze code, maar korter en minder selecteren is het wel.

Wigi

 

[Withaar]

Ik heb hem wel even getest. Hij werkt (helaas) niet.

Een paar opmerkingen,
For Each d In Range("A" & p, "A" & (p + l))
heb je veranderd in
For Each d In Range("A1").Resize(2)
Vermoedelijk in de veronderstelling dat het om P+1 gaat dit is echter de L die verwijst naar;
l = Sheets("overzicht per lijn").Range("A" & Rows.Count).End(xlUp).Row
Een regel die er in je code nu een beetje verloren bij staat...
N.b. wat moet ik me voorstellen bij 'Range("A1").Resize(2)'?
En ik krijg een foutmelding, De sorteer sleutel is ongeldig.

 

[Wigi]

Is dit al beter?

For Each d In Range("A1").Resize(l+1)

Ik moet mss toch eens het bestandje openen.

Zal iets voor morgenavond worden.

 

[Withaar]

Ja, als een stuk beter.
Probleem is nog dat ook de rijen met alleen een waarde in kolom A mee gaan.

N.b. los van dat probleem kan de code dan al terug tot:

Sub test4()
    Dim d As Range
    Application.EnableEvents = False
    Sheets("chroverz").Range("A4:Q" & Sheets("chroverz").Range("A" & Rows.Count).End(xlUp).Row + 3).ClearContents
        For Each d In Sheets("overzicht per lijn").Range("A1").Resize(Sheets("overzicht per lijn").Range("A" & Rows.Count).End(xlUp).Row + 1)
          If d.Offset(, 2) <> "" Then _
            d.Resize(, 17).Copy Sheets("chroverz").Range("A" & Sheets("chroverz").Range("A" & Rows.Count).End(xlUp).Row + 4)
    Next
    Sheets("chroverz").Range("A4:Q" & Sheets("chroverz").Range("A" & Rows.Count).End(xlUp).Row).Sort Key1:=Range("B4"), _
        Order1:=xlAscending, Key2:=Range("C4"), Order2:=xlAscending, Key3:=Range("D4"), Order3:=xlAscending
    Application.EnableEvents = True
End Sub

 

[DeVenter]

Heren,

Hartelijk dank: hier heb ik een hoop van geleerd.
Bovendien werkt het (los van die waarde in kolom A) goed.

Bedankt,
DeVenter :thumb:

 

[Wigi]

Bovendien werkt het (los van die waarde in kolom A) goed.

Als er nog iets moet gebeuren, laat het dan maar weten. Wel:

1. meest recente bestandje terug bijvoegen
2. meest recente code
3. duidelijke uitleg van wat er nog moet gebeuren.

Indien niet, veel plezier ermee en tot de volgende.

Wigi