vba 宏按列中的一系列值对行进行分组？
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/16587876/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
提示：将鼠标放在中文语句上可以显示对应的英文。显示中英文
时间：2020-09-11 21:08:52 来源:igfitidea点击:
Macro to group rows by a range of values in a column?
提问by Jamie Walker
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.
我有一个电子表格，其中有一列每小时的吨数为 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（Metric Tons Per Hour）、10-15 MTPH 等。任何帮助深表感谢。我实际上是在尝试帮助一个人解决这个问题，这是他迄今为止编写的代码。它不是很干净，但我不想花时间清理不会使用的代码。它现在可以工作，但不会 如果将新项目添加到列表中，则不起作用。我曾尝试在底部分组前后添加图片，但我认为它们不起作用。您可以尝试访问这些链接，它们可能会出现。只是为了看看我要做什么。
file:///C:/Users/walkerja/Pictures/Before%20Grouping.gif file:///C:/Users/walkerja/Pictures/After%20Grouping.gif
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
采纳答案by Skip Intro
Code amended from Santosh's excellent answer. This assumes you have a blank Column A and that Column I holds your data.
从 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
回答by Santosh
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
