Dalla una tabella a 5 sec ragrupparla ad una di 1 min

Sub perMinuto()
Dim ur As Long, i As Long, j As Long
ur = Cells(Rows.Count, 1).End(xlUp).Row
j = 1
For i = 2 To ur Step 11
  j = j + 1
  Range("A" & i & ":F" & i).Copy
  Range("J" & j & ":O" & j).PasteSpecial (xlPasteValues)
Next i
End Sub

Sub Minuto()
Dim Ur As Long, X As Long, Y As Long, W As Long, Ni As Long, Nf As Long
Dim Iniz As Date, Nuova As Date, Fine As Date
Ur = Cells(Rows.Count, 10).End(xlUp).Row
If Ur > 1 Then Range("J2:O" & Ur).Clear
Ur = Cells(Rows.Count, 1).End(xlUp).Row
Y = 2
For X = 2 To Ur
    Iniz = Format(Cells(X, 1), "hh:nn")
    If Iniz <> Nuova Then
        Range("A" & X & ":F" & X).Copy
        Range("J" & Y).PasteSpecial '(xlPasteValues)
        Nuova = Iniz
    Else
        Ni = X - 1
        Fine = Iniz + "00:01:00"
        Fine = Int(Cells(X, 1)) + Fine
        For W = X To Ur
            If Cells(W, 1) < Fine Then Nf = Nf + 1 Else Exit For
        Next W
        'Cells(Y, 11) = WorksheetFunction.???(Range(Cells(Ni, 2), Cells(Ni + Nf, 2)))
        Cells(Y, 12) = WorksheetFunction.Max(Range(Cells(Ni, 3), Cells(Ni + Nf, 3)))
        Cells(Y, 13) = WorksheetFunction.Min(Range(Cells(Ni, 4), Cells(Ni + Nf, 4)))
        'Cells(Y, 14) = WorksheetFunction.???(Range(Cells(Ni, 5), Cells(Ni + Nf, 5)))
        Cells(Y, 15) = WorksheetFunction.Sum(Range(Cells(Ni, 6), Cells(Ni + Nf, 6)))
        X = Ni + Nf
        Y = Y + 1
        Ni = 0
        Nf = 0
    End If
Next X
MsgBox "Fatto"
End Sub

Option Explicit

Sub perMinuto()
Dim ur As Long, i As Long, k As Long, j As Long, iniz As Date
ur = Cells(Rows.Count, 10).End(xlUp).Row
If ur > 1 Then Range("J2:O" & ur).ClearContents
ur = Cells(Rows.Count, 1).End(xlUp).Row
j = 1
For i = 2 To ur
  iniz = Format(Cells(i, 1), "hh:mm")
  For k = i + 1 To ur
    If Format(Cells(k, 1), "hh:mm") = iniz + "00:01:00" Then
      j = j + 1
      Cells(j, 10) = iniz
      Cells(j, 11) = Cells(i, 2).Value
      Cells(j, 12) = Application.WorksheetFunction.Max(Range(Cells(i, 3), Cells(k - 1, 3)))
      Cells(j, 13) = Application.WorksheetFunction.Min(Range(Cells(i, 4), Cells(k - 1, 4)))
      Cells(j, 14) = Cells(k, 5).Value
      Cells(j, 15) = Application.WorksheetFunction.Sum(Range(Cells(i, 6), Cells(k - 1, 6)))
      i = k - 1
      Exit For
    End If
  Next k
Next i
Cells(1, 10).Select
End Sub

Cells(j, 14) = Cells(k - 1, 5).value