Regels met tijdsduur splitsen op basis van tijdsduur

[jmdejong]

Ik heb een groot excelbestand met 6000 regels vergelijkbaar aan onderstaande:

Afspraak datum Act Van Tot duur
1-3-13 ET 12:30 13:00 0:30
1-3-13 TDIR 13:00 13:30 0:30
1-3-13 CC 14:00 15:00 1:00
1-3-13 CE 14:00 15:00 1:00

Voor onderzoeksredenen wil ik alle afspraken die een grotere duur hebben dan 0:30 splitsen in meerdere regels van duur=0:30 met aangepaste begin- en eindtijden (voorbeeld in onderstaande tabel)

Afspraak datum Act Van Tot duur
1-3-13 ET 12:30 13:00 0:30
1-3-13 TDIR 13:00 13:30 0:30
1-3-13 CC 14:00 14:30 0:30
1-3-13 CC 14:30 15:00 0:30
1-3-13 CE 14:00 14:40 0:30
1-3-13 CE 14:30 15:00 0:30

Als iemand een idee heeft hoe ik deze handeling met een macro kan uitvoeren, dan ben ik erg uit de brand geholpen.

Groeten,
jmdejong

 

[Elsendoorn2134]

Mr. de Jong,

Hierbij een bestandje hoe je dit probleem met VBA kunt oplossen.

Veel Succes.

Bekijk bijlage HelpMijSplitsTijden.xlsm

 

[jmdejong]

Hallo Elsendoorn,

Dank voor de hulp. Dit is inderdaad de oplossing waar ik naar zocht.

Met vriendelijke groet,
jmdejong

 

[snb]

Om het aantal schrijfbewerkingen te minimaliseren:

Sub M_snb()
    With Sheets("Blad1").Cells(1).CurrentRegion
        sn = .Value
        sp = .Resize(2 * .Rows.Count)
    End With
    
    For j = 2 To UBound(sn)
        For jjj = 1 To 4
            sp(j + jj, jjj) = sn(j, jjj)
            If sn(j, 5) = 6 / 144 Then sp(j + jj + 1, jjj) = sn(j, jjj)
        Next
        sp(j + jj, 5) = 3 / 144

        If sn(j, 5) = 6 / 144 Then
           jj = jj + 1
           sp(j + jj - 1, 4) = sn(j, 4) - 3 / 144
           sp(j + jj , 3) = sn(j, 3) + 3 / 144
           sp(j + jj , 5) = 3 / 144
        End If
    Next
    
    Sheets("Blad1").Cells(1).Offset(, 7).Resize(UBound(sp), UBound(sp, 2)) = sp
End Sub