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等组描述。任何帮助深表感谢。我实际上是想用这个来帮助一个人，这是他到目前为止编写的代码。它不是很干净，但我不想花时间清理不会使用的代码。它现在可以正常工作，但如果将新项目添加到列表中，它将无法工作。我试图在底部分组之前和之后添加图片，但我不认为它们正在工作。您可以尝试访问这些链接，他们可能会拉起来。只是为了看看我的目的。

文件：/// C：/Users/walkerja/Pictures/Before%20Grouping.gif 文件：/// 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

Before Grouping

After Grouping

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

enter image description here

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

宏按行中的一系列值对行进行分组？

2 个答案: