0

我按每小时公吨对这张表进行排序，到目前为止我的代码删除了标题（第二行向下移动了），我不知道如何使这种情况不发生。此外，我想在列表排序后合并最左列中的单元格，以便将不同的数字范围分组，而不是在每一行中说明范围。我需要范围为 6-8、10-15、16-21、24-28。提前致谢。

Sub SystemSize()

Dim LastRow As Long
LastRow = Range("I" & Rows.Count).End(xlUp).Row
Dim I As Long, Groups As Long

Range("A2:I" & LastRow).Sort key1:=Range("I2"), order1:=xlAscending 'Sorts data

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) <= 8 Then
            Cells(j, 1) = "6-8 MTPH" 'Cells(j, 1)
             I = I + 1
        End If
    Next
Case 2


    For j = 2 To LastRow
        If Cells(j, 9) >= 10 And Cells(j, 9) <= 15 Then
            Cells(j, 1) = "10-15 MTPH"
             I = I + 1
        End If
    Next

Case 3


    For j = 2 To LastRow
        If Cells(j, 9) >= 16 And Cells(j, 9) <= 21 Then
            Cells(j, 1) = "16-21 MTPH"
             I = I + 1
        End If
    Next

Case 4

    For j = 2 To LastRow
        If Cells(j, 9) >= 24 And Cells(j, 9) <= 28 Then
            Cells(j, 1) = "24-28 MTPH"
             I = I + 1
        End If
    Next

Case 5

    For j = 2 To LastRow
        If Cells(j, 9) >= 30 And Cells(j, 9) <= 38 Then
            Cells(j, 1) = "30-38 MTPH"
        End If
    Next

Case 6

    For j = 2 To LastRow
        If Cells(j, 9) >= 40 And Cells(j, 9) <= 48 Then
            Cells(j, 1) = "40-48 MTPH"
             I = I + 1
        End If
    Next

Case 7 'this added to pick up data that does not fall into a group, like 8 or 9
   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
4

2 回答 2

1

排序参数应该有一个选项来指定Header=xlYes或类似

Range("A2:I" & LastRow).Sort key1:=Range("I2"), order1:=xlAscending, Header:= xlYes 'Sorts data
于 2013-05-16T17:52:07.697 回答
0

我认为这应该可以帮助您进行合并。

在您的 之前End Sub，添加以下行以调用另一个过程：

MergeTableRows lastRow

然后，添加这个子例程，它应该根据相似的值在 A 列中进行合并。

Sub MergeTableRows(lastRow As Long)
Dim fullRange As Range
Dim firstCell As Range
Dim x As Integer 'cell counter
Dim rngToMerge As Range

    Set fullRange = Range("A2:I" & lastRow)

    x = 1
    Do
        If firstCell Is Nothing Then Set firstCell = fullRange.Cells(x, 1)

            'Determine how many cells by counting the number of like occurrences '
            countCells = Application.WorksheetFunction.CountIf( _
                    fullRange.Columns(1), firstCell.Value)

            'Set the range to be merged, using the Resize method '
            Set rngToMerge = firstCell.Resize(countCells, 1)

            'Disable alerts which will notify you that the cells contain values, only the 1st will be retained.'
            Application.DisplayAlerts = False
            'et voila!
            rngToMerge.Merge
            Application.DisplayAlerts = True

            'reset the firstCell to nothing
            Set firstCell = Nothing

        'proceed to the next unmerged row
        x = x + countCells
        'Do this loop only as long as x is less than the number of rows in our range'
    Loop While Not x >= fullRange.Rows.Count

End Sub

更新

有一些问题，因为这个数据表是 aListObject并且表仍然有AutoFilterMode = True，两者都阻止了单元格的合并。即使在功能区上，当这些条件存在时，合并和居中选项也会被禁用。

幸运的是，它们都很容易修复！

Sub SystemSize()

Dim lastRow As Long
lastRow = Range("I" & Rows.Count).End(xlUp).Row
Dim I As Long, Groups As Long
Dim rngTable As Range
Dim ws As Worksheet

Set ws = ActiveSheet
Set rngTable = ws.Range("A2:I" & lastRow)
rngTable.Sort key1:=Range("I2"), order1:=xlAscending, Header:=xlYes 'Sorts data


'## THE REST OF YOUR CODE UNCHANGED GOES HERE ##
'## THE REST OF YOUR CODE UNCHANGED GOES HERE ##
'## THE REST OF YOUR CODE UNCHANGED GOES HERE ##
'## THE REST OF YOUR CODE UNCHANGED GOES HERE ##


ws.AutoFilterMode = False

On Error Resume Next
ws.ListObjects("Table 1").Unlist
On Error GoTo 0

MergeTableRows lastRow

ws.Columns("C:K").EntireColumn.Hidden = True

End Sub
于 2013-05-16T19:43:48.600 回答