bepaalde regels kopieren

[Klus]

Beste forumleden,

Ik zit met een uitdaging die mijn VBA kennis te boven gaat. Heb al op het forum gezocht maar het kopieren van bapaalde regels op deze manier kom ik niet tegen.

Ik heb een lijst met gebeurtenissen (soms tot 30000 regels) waarin per regel een datum/tijd staat met een aantal kolommen betreffende die gebeurtenis , meestal meerdere regels per dag. Nu wil ik graag van elke dag de eerste en de laatste gebeurtenis overhouden, deze moeten gekopieerd worden naar het tweede tabblad.

Is er iemand die mij hiermee kan helpen. Het liefst in VBA met wat uitleg over de code.
Ik hoop er zo nog wat van te leren ook.

Alvast bedankt voor een ieder die er aandacht aan besteedt.

Zie bijlage voor een voorbeeld bestand met uitleg.

Gr. Marco

 

[HSV]

Probeer deze eens.

Sub tst()
  With Sheets("Blad1")
   For Each cl In .Range("A4:A" & .Cells.SpecialCells(xlCellTypeLastCell).Row) 'doorloop alle cellen van blad1 kolom A
    On Error Resume Next 'stel dat een cel geen datum is, dan ga door bij een fout
      If CLng(cl) <> CLng(cl.Offset(-1)) Then 'als een datum niet gelijk is aan de cel erboven dan naar volgende regel anders naar end if
       If CLng(cl) <> Empty And cl.Offset(1) <> Empty Then 'als de cellen niet leeg zijn
      On Error GoTo 0 'zet de foutafvanging weer op nul
     With Sheets("Blad2") 'met blad2
      .Cells(.Rows.Count, 1).End(xlUp).Offset(1).EntireRow.Value = cl.EntireRow.Value 'zet de gevonden cel onder de laatst ingevulde cel van kolom A (blad2)
     End With
    End If
   End If
  Next 'volgende cel
 End With
End Sub

 

[Klus]

Beste Harry,

Alvast bedankt voor je moeite. Hij vult inderdaad wel het tweede tabblad maar niet helemaal met de juiste gegevens.
Hij neemt vaak wel de eerste gebeurtenis van een dag maar niet de laatste. Bij (bijna) allemaal pakt hij een gebeurtenis ergens halverwege de dag. Meestal rond 12:00.
Ook pakt hij niet van elke dag de eerste en laatste gebeurtenis. Bij sommige dagen staat er maar 1 gebeurtenis in.
De eerste gebeurtenis van een dag gaat volgens mij redelijk, de tweede die gekopieerd moet worden naar Blad2 (en dus laatste gebeurtenis van diezelfde dag) lijkt wel alsof hij de eerste gebeurtenis kopieert na 12:00 i.p.v. de laatste.

Is het misschein beter om die kolom te scheiden qua datum en tijd ?

Alvast dank
Gr. Marco

 

[Roncancio]

In bijgevoegd macro ga ik ervan uit dat de datums en tijden zijn gescheiden.

Sub Kopieren()
Dim lRij As Long
Dim lSRij As Long
Dim iNP As Integer

    lRij = 4
    lSRij = lRij
    While Range("A" & lRij).Value <> ""
        With Blad1
            Blad2.Range("A" & lSRij & ":E" & lSRij).Value = .Range("A" & lRij & ":E" & lRij).Value
            iNP = Application.WorksheetFunction.CountIf(.Range("A4:A37"), .Range("A" & lRij))
            lSRij = lSRij + 1
            Blad2.Range("A" & lSRij & ":E" & lSRij).Value = .Range("A" & lRij + iNP - 1 & ":E" & lRij + iNP - 1).Value
        End With
        lSRij = lSRij + 1
        lRij = lRij + iNP
    Wend
End Sub

Met vriendelijke groet,


Roncancio

 

[HSV]

Mijn excuses.

Nieuwe poging.
Zonder ze te scheiden.

Sub tst()
  With Sheets("Blad1")
   For Each cl In .Range("A4:A" & .Cells.SpecialCells(xlCellTypeLastCell).Row) 'doorloop alle cellen van blad1 kolom A
    On Error Resume Next 'stel dat een cel geen datum is, dan ga door bij een fout
      If DateValue(cl) <> DateValue(cl.Offset(1)) Or DateValue(cl) <> DateValue(cl.Offset(-1)) Then 'als een datum niet gelijk is aan de cel erboven dan naar volgende regel anders naar end if
       If DateValue(cl) <> Empty And cl.Offset(1) <> Empty Then 'als de cellen niet leeg zijn
      On Error GoTo 0 'zet de foutafvanging weer op nul
     With Sheets("Blad2") 'met blad2
      .Cells(.Rows.Count, 1).End(xlUp).Offset(1).EntireRow.Value = cl.EntireRow.Value 'zet de gevonden cel onder de laatst ingevulde cel van kolom A (blad2)
     End With
    End If
   End If
  Next 'volgende cel
 End With
End Sub

 

[Klus]

Beste Harry,

Deze laatste code is helemaal geweldig en doet precies wat ik wilde bereiken. Heel veel dank voor de moeite en de bijgevoegde uitleg. Ik ga proberen te analyseren wat er allemaal gebeurt in die code. Goed voor het leerproces :thumb:

@ Roncancio
Ook erg bedankt voor de moeite maar de code gaf een foutmelding bij de regel voor de "End With". Blad2 bleek vanaf regel 30 tot aan de laatste regel gevuld te zijn met 2 regels uit de oorspronkelijke data. Om en om.

Nogmaals dank aan aan Harry en Roncancio voor de hulp. Ik zet de vraag op opgelost.

Gr. Marco