0

このテーブルを 1 時間あたりのトン数で並べ替えていますが、これまでのコードでヘッダーが削除され (下の 2 行目は上に移動しただけです)、これが起こらないようにする方法がわかりません。また、リストがソートされたら、左端の列のセルをマージして、各行の範囲を示すのではなく、異なる数値範囲をグループ化します。範囲を 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

更新しました

このデータ テーブルは でListObjectあり、テーブルにはまだ が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 に答える