MAcro que cuente por Hora y dia

Mmmm tu bucle no dice mucho mas alla de la funcionalidad explicita del mismo. Entiendo lo que intentas obtener
Dame un ejemplo de la data y como esta distribuido ( esta en una celda como cadena o en varias )
A ver que se me ocurre

Buen dia
Gracias por la atencion, la data esta esta mas o mens asi
Fecha Hora Tipo de Transaccion
01/09/2011 16:06:22 X
01/09/2011 13:08:43 Y
3/09/2011 08:22:15 X
Y asi hasta la fila 25000 lo que deseo es que me envie a una nueva hoja a celdas que yo le defina tomando lo anterior como ejemplo
Fecha Rango de Hora Cant Transacciones
01/09/2011 13 - 14 1
01/09/2011 16- 17 1
03/09 08- 09 1
Y si sucesivamente por todas ls horas y fechas del archivo.

Ok. Prueba esto
Inserta un modulo y pegas todo esto:
Option Explicit
Public cadena As String
Sub rangos()
Dim r As Range
Dim n As Long
Dim f As Long
n = Application.WorksheetFunction.CountA(Sheets(1).Range("A:A"))
If n = 0 Then Exit Sub
f = Application.WorksheetFunction.CountA(Sheets(2).Range("A:A")) + 1
Application.ScreenUpdating = False
formato
For Each r In Sheets(1).Range("A1" & ":" & "A" & n)
tramo (Format(r.Offset(0, 1), "HH"))
Sheets(2).Range("A" & f) = r
Sheets(2).Range("B" & f) = cadena
Sheets(2).Range("C" & f) = Sheets(2).Range("C" & f) + 1
f = (f + 1)
DoEvents
Next
formular
Set r = Nothing
Application.ScreenUpdating = False
MsgBox "Terminado", vbInformation
End Sub
Sub tramo(h As Integer)
If h <= 1 Then cadena = "0-1"
If h > 1 And h <= 2 Then cadena = "1-2"
If h >= 2 And h <= 3 Then cadena = "2-3"
If h >= 3 And h <= 4 Then cadena = "3-4"
If h >= 4 And h <= 5 Then cadena = "4-5"
If h >= 5 And h <= 6 Then cadena = "5-6"
If h >= 6 And h <= 7 Then cadena = "6-7"
If h >= 7 And h <= 8 Then cadena = "7-8"
If h >= 8 And h <= 9 Then cadena = "8-9"
If h >= 9 And h <= 10 Then cadena = "9-10"
If h >= 10 And h <= 11 Then cadena = "10-11"
If h >= 11 And h <= 12 Then cadena = "11-12"
If h >= 12 And h <= 13 Then cadena = "12-13"
If h >= 13 And h <= 14 Then cadena = "13-14"
If h >= 14 And h <= 15 Then cadena = "14-15"
If h >= 15 And h <= 16 Then cadena = "15-16"
If h >= 16 And h <= 17 Then cadena = "16-17"
If h >= 17 And h <= 18 Then cadena = "17-18"
If h >= 18 And h <= 19 Then cadena = "18-19"
If h >= 19 And h <= 20 Then cadena = "19-20"
If h >= 20 And h <= 21 Then cadena = "20-21"
If h >= 21 And h <= 22 Then cadena = "21-22"
If h >= 22 And h <= 23 Then cadena = "22-23"
If h >= 23 And h <= 24 Then cadena = "23-0"
End Sub
Sub formular()
Dim n As Long
Sheets(2).Select
n = Application.WorksheetFunction.CountA(Range("A:A"))
Range("D2").Select
ActiveCell.FormulaR1C1 = "=SUMIFS(C[-1],C[-3],RC[-3],C[-2],RC[-2])"
Range("D2").Select
Selection.AutoFill Destination:=Range("D2:" & "D" & n)
Range("D2:" & "D" & n).Select
Selection.Cut
Range("C2").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Range("A2:" & "C" & n).Select
Sheets(2).Range("$A$1:" & "$C$" & n).RemoveDuplicates Columns:=Array(1, 2), Header _
:=xlYes
Range("A1").Select
End Sub
Sub formato()
Sheets(2).Select
Columns("A:A").Select
Selection.NumberFormat = "m/d/yyyy"
Columns("B:B").Select
Selection.NumberFormat = "@"
Sheets(1).Select
End Sub
Los datos deben estar en hoja1 desde fila 1 ( sin rotulos)
El resumen se quedara en hoja2
Debes esperar a que el macro te indique que a finalizado mediante un mensaje en pantalla.
Bye

me falto algo ... ahora si esta:
Option Explicit
Public cadena As String
Sub rangos()
Dim r As Range
Dim n As Long
Dim f As Long
n = Application.WorksheetFunction.CountA(Sheets(1).Range("A:A"))
If n = 0 Then Exit Sub
f = Application.WorksheetFunction.CountA(Sheets(2).Range("A:A")) + 1
Application.ScreenUpdating = False
formato
For Each r In Sheets(1).Range("A1" & ":" & "A" & n)
tramo (Format(r.Offset(0, 1), "HH"))
Sheets(2).Range("A" & f) = r
Sheets(2).Range("B" & f) = cadena
Sheets(2).Range("C" & f) = Sheets(2).Range("C" & f) + 1
f = (f + 1)
DoEvents
Next
formular
Set r = Nothing
Application.ScreenUpdating = False
MsgBox "Terminado", vbInformation
End Sub
Sub tramo(h As Integer)
If h <= 1 Then cadena = "0-1"
If h > 1 And h <= 2 Then cadena = "1-2"
If h >= 2 And h <= 3 Then cadena = "2-3"
If h >= 3 And h <= 4 Then cadena = "3-4"
If h >= 4 And h <= 5 Then cadena = "4-5"
If h >= 5 And h <= 6 Then cadena = "5-6"
If h >= 6 And h <= 7 Then cadena = "6-7"
If h >= 7 And h <= 8 Then cadena = "7-8"
If h >= 8 And h <= 9 Then cadena = "8-9"
If h >= 9 And h <= 10 Then cadena = "9-10"
If h >= 10 And h <= 11 Then cadena = "10-11"
If h >= 11 And h <= 12 Then cadena = "11-12"
If h >= 12 And h <= 13 Then cadena = "12-13"
If h >= 13 And h <= 14 Then cadena = "13-14"
If h >= 14 And h <= 15 Then cadena = "14-15"
If h >= 15 And h <= 16 Then cadena = "15-16"
If h >= 16 And h <= 17 Then cadena = "16-17"
If h >= 17 And h <= 18 Then cadena = "17-18"
If h >= 18 And h <= 19 Then cadena = "18-19"
If h >= 19 And h <= 20 Then cadena = "19-20"
If h >= 20 And h <= 21 Then cadena = "20-21"
If h >= 21 And h <= 22 Then cadena = "21-22"
If h >= 22 And h <= 23 Then cadena = "22-23"
If h >= 23 And h <= 24 Then cadena = "23-0"
End Sub
Sub formular()
Dim n As Long
Sheets(2).Select
n = Application.WorksheetFunction.CountA(Range("A:A"))
Range("D2").Select
ActiveCell.FormulaR1C1 = "=SUMIFS(C[-1],C[-3],RC[-3],C[-2],RC[-2])"
Range("D2").Select
Selection.AutoFill Destination:=Range("D2:" & "D" & n)
Range("D2:" & "D" & n).Select
Selection.Copy
Selection.Cut
Range("C2").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Range("A2:" & "C" & n).Select
Sheets(2).Range("$A$1:" & "$C$" & n).RemoveDuplicates Columns:=Array(1, 2), Header _
:=xlYes
Range("A1").Select
End Sub
Sub formato()
Sheets(2).Select
Columns("A:A").Select
Selection.NumberFormat = "m/d/yyyy"
Columns("B:B").Select
Selection.NumberFormat = "@"
Sheets(1).Select
End Sub