excel - 宏按列中的值范围对行进行分组？

Question

我有一个电子表格，其中有一列每小时吨数为 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。我需要一个宏来按这些排序并按这些值对它们进行分组。我需要宏将它们按 6-7、10-15、16-21、24-28、30-38 和 40-48 分组。我知道如何对列进行排序，但我不确定是否有代码告诉它将行分组到这些存储桶中。它还需要在最左侧创建一个列，其中包含组描述，例如 6-7 MTPH（公吨每小时）、10-15 MTPH 等。任何帮助深表感谢。我实际上是在尝试帮助一个人，这是他迄今为止编写的代码。它不是很干净，但我不想花时间清理不会使用的代码。它现在有效，但不会 如果将新项目添加到列表中，则无法正常工作。我曾尝试在底部分组前后添加图片，但我认为它们不起作用。您可以尝试访问这些链接，它们可能会弹出。只是想看看我要做什么。

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

试试下面的代码：

  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

Answer 2

根据 Santosh 的出色回答修改了代码。这假设您有一个空白列 A 并且该列 I 保存您的数据。

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