Question

我按每小时公吨计算这个表格，到目前为止我的代码删除了标题（第二行向下移动了）我无法弄清楚如何使这不发生。此外，我希望在列表排序后合并最左侧列中的单元格，以便对不同的数字范围进行分组，而不是说明每行中的范围。我需要的范围是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

Answer 1

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

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

Answer 2

我认为这可以帮助你进行合并。

在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

<强>已更新

存在一些问题，因为此数据表为ListObject且表格仍为AutoFilterMode = True，两者都阻止了单元格的合并。即使在功能区上，Merge＆amp;当存在这些条件时，中心选项被禁用。

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

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

代码替换表头，不会合并行

2 个答案: