Excel - Crear resumen con macro

Option Explicit

'//By JuanC - 08 Oct. 2011

Type tt

     sHora As String

     col As Collection

End Type

Sub test()

Dim rng As Range, cell As Range

Dim v() As tt, flg As Boolean

Dim n%, i%, h%, m%, sHora$, k%, p%

Application.ScreenUpdating = False

Set rng = Hoja3.Range("J6:J125")

n = -1

For Each cell In rng

    If VBA.Trim(cell.Text) <> "" Then

       flg = False

       For i = 0 To n

           If v(i).sHora = cell.Text Then

              flg = True

              v(i).col.Add cell.Offset(, -8).Value & "@" & cell.Offset(, -4).Value

              Exit For

           End If

       Next

       If Not flg Then

          n = n + 1

          ReDim Preserve v(n)

          v(n).sHora = cell.Text

          Set v(n).col = New Collection

          v(n).col.Add cell.Offset(, -8).Value & "@" & cell.Offset(, -4).Value

       End If

    End If

Next

Hoja5.Cells.Clear

Set rng = Hoja5.Range("B2")

p = 0

For h = 0 To 23

    For m = 0 To 45 Step 15

        sHora = h & ":" & Format(m, "00")

        rng.Offset(p, 0).NumberFormat = "@"

        rng.Offset(p, 0).Value = sHora

        flg = False

        For i = 0 To n

            If v(i).sHora = sHora Then

               If v(i).col.Count > 0 Then

                  flg = True

                  p = p + 1

               End If

               For k = 1 To v(i).col.Count

                   rng.Offset(p, 0).Value = VBA.Split(v(i).col.Item(k), "@")(0)

                   rng.Offset(p, 1).Value = VBA.Split(v(i).col.Item(k), "@")(1)

                   p = p + 1

               Next

               Exit For

            End If

        Next

        If Not flg Then rng.Offset(p, 0).Value = ""

    Next

Next

Erase v

Application.ScreenUpdating = True

End Sub