Macro to group rows by a range of values in a column?

Question

I have a spreadsheet that has a column with ton per hour numbers that are 6, 7, 8, 10, 11, 12, 12.5, 13, 14.5, 15, 18, 20, 21, 24, 25, 27, 28, 30, 33, 35, 38, 40, 43, 45, 47, 48. I need a macro that will sort by these and group them by these values. I need the macro it to group them by 6-7, 10-15, 16-21, 24-28, 30-38, and 40-48. I know how to sort the column but I'm not sure about a code to tell it to group the rows into these buckets. It also needs to create a column on the far left with the groups description such as 6-7 MTPH (Metric Tons Per Hour), 10-15 MTPH and so on. Any help is much appreciated. I'm actually trying to help a guy with this and this is the code he has written so far. It's not very clean but I didn't want to take the time to clean up code that won't be used. It works right now but it won't work if new items are added to the list. I have tried to add pictures before and after grouping at the bottom but I don't think they're working. You can try going to these links and they might pull up. Just to see what I'm going for.

file:///C:/Users/walkerja/Pictures/Before%20Grouping.gif file:///C:/Users/walkerja/Pictures/After%20Grouping.gif

Sub Size()
'
' Size Macro
'gets last cell


lastCell = Range("J1").End(xlDown).Select


'
Columns("A:A").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Columns("B:B").Select
Selection.EntireColumn.Hidden = True
Columns("D:D").Select
Selection.EntireColumn.Hidden = True
Columns("E:E").Select
Selection.EntireColumn.Hidden = True
Columns("F:F").Select
Selection.EntireColumn.Hidden = True
Columns("G:G").Select
Selection.EntireColumn.Hidden = True
Columns("I:I").Select
Selection.EntireColumn.Hidden = True
Columns("L:L").Select
Selection.EntireColumn.Hidden = True
Range("A1").Select
ActiveCell.FormulaR1C1 = "Size Range"
Range("J2:J1000").Select
ActiveWorkbook.Worksheets("Sheet1").ListObjects("Table2").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").ListObjects("Table2").Sort.SortFields.add _
    Key:=Range("J2"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
    :=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet1").ListObjects("Table2").Sort
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With
If lastCell >= 6 & lastCell <= 9 Then
Range("A2:A6").Select
Else
Range("A2:A5").Select
End If
With Selection
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlBottom
    .WrapText = False
    .Orientation = 0
    .AddIndent = False
    .IndentLevel = 0
    .ShrinkToFit = False
    .ReadingOrder = xlContext
    .MergeCells = False
End With
Selection.Merge
With Selection
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    .WrapText = False
    .Orientation = 0
    .AddIndent = False
    .IndentLevel = 0
    .ShrinkToFit = False
    .ReadingOrder = xlContext
    .MergeCells = True
End With
ActiveCell.FormulaR1C1 = "6-9 MTPH"
Range("A6:A31").Select
With Selection
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlBottom
    .WrapText = False
    .Orientation = 0
    .AddIndent = False
    .IndentLevel = 0
    .ShrinkToFit = False
    .ReadingOrder = xlContext
    .MergeCells = False
End With
Selection.Merge
ActiveCell.FormulaR1C1 = "10-15 MTPH"
Range("A6:A31").Select
With Selection
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    .WrapText = False
    .Orientation = 0
    .AddIndent = False
    .IndentLevel = 0
    .ShrinkToFit = False
    .ReadingOrder = xlContext
    .MergeCells = True
End With
ActiveWindow.SmallScroll Down:=9
Range("A32:A45").Select
With Selection
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlBottom
    .WrapText = False
    .Orientation = 0
    .AddIndent = False
    .IndentLevel = 0
    .ShrinkToFit = False
    .ReadingOrder = xlContext
    .MergeCells = False
End With
Selection.Merge
ActiveCell.FormulaR1C1 = "16-21 MTPH"
Range("A32:A45").Select
With Selection
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    .WrapText = False
    .Orientation = 0
    .AddIndent = False
    .IndentLevel = 0
    .ShrinkToFit = False
    .ReadingOrder = xlContext
    .MergeCells = True
End With
ActiveWindow.SmallScroll Down:=21
Range("A46:A59").Select
With Selection
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlBottom
    .WrapText = False
    .Orientation = 0
    .AddIndent = False
    .IndentLevel = 0
    .ShrinkToFit = False
    .ReadingOrder = xlContext
    .MergeCells = False
End With
Selection.Merge
ActiveCell.FormulaR1C1 = "24-28 MTPH"
Range("A46:A59").Select
With Selection
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    .WrapText = False
    .Orientation = 0
    .AddIndent = False
    .IndentLevel = 0
    .ShrinkToFit = False
    .ReadingOrder = xlContext
    .MergeCells = True
End With
ActiveWindow.SmallScroll Down:=18
Range("A79").Select
ActiveWindow.SmallScroll Down:=-3
Range("A60:A75").Select
With Selection
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlBottom
    .WrapText = False
    .Orientation = 0
    .AddIndent = False
    .IndentLevel = 0
    .ShrinkToFit = False
    .ReadingOrder = xlContext
    .MergeCells = False
End With
Selection.Merge
ActiveCell.FormulaR1C1 = "30-38 MTPH"
Range("A60:A75").Select
With Selection
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    .WrapText = False
    .Orientation = 0
    .AddIndent = False
    .IndentLevel = 0
    .ShrinkToFit = False
    .ReadingOrder = xlContext
    .MergeCells = True
End With
ActiveWindow.SmallScroll Down:=6
Range("A76:A94").Select
With Selection
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlBottom
    .WrapText = False
    .Orientation = 0
    .AddIndent = False
    .IndentLevel = 0
    .ShrinkToFit = False
    .ReadingOrder = xlContext
    .MergeCells = False
End With
Selection.Merge
ActiveCell.FormulaR1C1 = "40-48 MTPH"
Range("A76:A94").Select
With Selection
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    .WrapText = False
    .Orientation = 0
    .AddIndent = False
    .IndentLevel = 0
    .ShrinkToFit = False
    .ReadingOrder = xlContext
    .MergeCells = True
End With
Range("C90").Select
ActiveWindow.SmallScroll Down:=-75
Range("A1:A1000").Select
Range("A1").Select
With Selection.Interior
    .Pattern = xlSolid
    .PatternColorIndex = xlAutomatic
    .ThemeColor = xlThemeColorAccent1
    .TintAndShade = 0
    .PatternTintAndShade = 0
End With
With Selection.Font
    .Name = "Times New Roman"
    .FontStyle = "Bold"
    .Size = 10
    .Strikethrough = False
    .Superscript = False
    .Subscript = False
    .OutlineFont = False
    .Shadow = False
    .Underline = xlUnderlineStyleSingle
    .ThemeColor = xlThemeColorDark1
    .TintAndShade = 0
    .ThemeFont = xlThemeFontNone
End With
End Sub

Answer 1

Code amended from Santosh's excellent answer. This assumes you have a blank Column A and that Column I holds your data.

Sub MTPH()

Dim lastRow As Long
Dim i As Long, groups As Long
Dim intStart As Integer
Dim intFinish As Integer

lastRow = Range("I" & Rows.Count).End(xlUp).row
Range("A2:I" & lastRow).sort key1:=Range("I2"), order1:=xlAscending

groups = 1


Do While groups < 8
 i = 2
    Select Case groups
      Case 1


        For j = 2 To lastRow

            If Cells(j, 9) >= 6 And Cells(j, 9) <= 7 Then

                If intStart > 0 Then
                    intStart = intStart
                        Else
                        intStart = j
                End If

                intEnd = j

                Cells(j, 1) = "6-7 MTPH" 'Cells(j, 1)
                 i = i + 1
            End If
        Next

        strRangeToMerge = "A" & intStart & ":A" & intEnd

        Application.DisplayAlerts = False

        With Range(strRangeToMerge)
            .Merge
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
        End With

        Application.DisplayAlerts = True

        intStart = 0

    Case 2


        For j = 2 To lastRow
            If Cells(j, 9) >= 10 And Cells(j, 9) <= 15 Then

                If intStart > 0 Then
                    intStart = intStart
                        Else
                        intStart = j
                End If

                intEnd = j

                Cells(j, 1) = "10-15 MTPH"
                 i = i + 1
            End If
        Next

        strRangeToMerge = "A" & intStart & ":A" & intEnd

        Application.DisplayAlerts = False

        With Range(strRangeToMerge)
            .Merge
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
        End With

        Application.DisplayAlerts = True

        intStart = 0


    Case 3

        'Cells(1, 4) = "'16-21"
        For j = 2 To lastRow
            If Cells(j, 9) >= 16 And Cells(j, 9) <= 21 Then

             If intStart > 0 Then
                    intStart = intStart
                        Else
                        intStart = j
                End If

            intEnd = j

                Cells(j, 1) = "16-21 MTPH"
                 i = i + 1
            End If
        Next

        strRangeToMerge = "A" & intStart & ":A" & intEnd

        Application.DisplayAlerts = False

        With Range(strRangeToMerge)
            .Merge
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
        End With

        Application.DisplayAlerts = True

        intStart = 0


    Case 4
        'Cells(1, 5) = "'24-28"
        For j = 2 To lastRow
            If Cells(j, 9) >= 24 And Cells(j, 9) <= 28 Then

             If intStart > 0 Then
                    intStart = intStart
                        Else
                        intStart = j
                End If

            intEnd = j

                Cells(j, 1) = "24-28 MTPH"
                 i = i + 1
            End If
        Next


          strRangeToMerge = "A" & intStart & ":A" & intEnd

        Application.DisplayAlerts = False

        With Range(strRangeToMerge)
            .Merge
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
        End With

        Application.DisplayAlerts = True

        intStart = 0

    Case 5
        'Cells(1, 6) = "'30-38"
        For j = 2 To lastRow
            If Cells(j, 9) >= 30 And Cells(j, 9) <= 38 Then

             If intStart > 0 Then
                    intStart = intStart
                        Else
                        intStart = j
                End If

            intEnd = j

                Cells(j, 1) = "30-38 MTPH"
            End If
        Next


          strRangeToMerge = "A" & intStart & ":A" & intEnd

        Application.DisplayAlerts = False

        With Range(strRangeToMerge)
            .Merge
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
        End With

        Application.DisplayAlerts = True

        intStart = 0

    Case 6
        'Cells(1, 7) = "'40-48"
        For j = 2 To lastRow
            If Cells(j, 9) >= 40 And Cells(j, 9) <= 48 Then

             If intStart > 0 Then
                    intStart = intStart
                        Else
                        intStart = j
                End If

            intEnd = j

                Cells(j, 1) = "40-48 MTPH"
                 i = i + 1
            End If
        Next

          strRangeToMerge = "A" & intStart & ":A" & intEnd

        Application.DisplayAlerts = False

        With Range(strRangeToMerge)
            .Merge
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
        End With

        Application.DisplayAlerts = True

        intStart = 0

    Case 7
       For j = 2 To lastRow
            If Cells(j, 9) > 0 And Cells(j, 9) < 6 Or Cells(j, 9) > 48 Then
                Cells(j, 1) = "No Group"
                 i = i + 1
            End If
        Next

    End Select

    groups = groups + 1
Loop

End Sub

Answer 2

Try below code :

  Sub sample()

    Dim lastRow As Long
    lastRow = Range("A" & Rows.Count).End(xlUp).Row
    Dim i As Long, groups As Long

    groups = 1


    Do While groups < 7
     i = 2
        Select Case groups
          Case 1
            Cells(1, 2) = "'6-7"

            For j = 2 To lastRow
                If Cells(j, 1) >= 6 And Cells(j, 1) <= 7 Then
                    Cells(i, 2) = Cells(j, 1)
                     i = i + 1
                End If
            Next
        Case 2

            Cells(1, 3) = "'10-15"
            For j = 2 To lastRow
                If Cells(j, 1) >= 10 And Cells(j, 1) <= 15 Then
                    Cells(i, 3) = Cells(j, 1)
                     i = i + 1
                End If
            Next

        Case 3

            Cells(1, 4) = "'16-21"
            For j = 2 To lastRow
                If Cells(j, 1) >= 16 And Cells(j, 1) <= 21 Then
                    Cells(i, 4) = Cells(j, 1)
                     i = i + 1
                End If
            Next

        Case 4
            Cells(1, 5) = "'24-28"
            For j = 2 To lastRow
                If Cells(j, 1) >= 24 And Cells(j, 1) <= 28 Then
                    Cells(i, 5) = Cells(j, 1)
                     i = i + 1
                End If
            Next

        Case 5
            Cells(1, 6) = "'30-38"
            For j = 2 To lastRow
                If Cells(j, 1) >= 30 And Cells(j, 1) <= 38 Then
                    Cells(i, 6) = Cells(j, 1)
                End If
            Next

        Case 6
            Cells(1, 7) = "'40-48"
            For j = 2 To lastRow
                If Cells(j, 1) >= 40 And Cells(j, 1) <= 48 Then
                    Cells(i, 7) = Cells(j, 1)
                     i = i + 1
                End If
            Next

        End Select

        groups = groups + 1
    Loop

End Sub