Как отсортировать список данных на основе трех столбцов в правильном порядке?

Question

Ниже вы видите фрагмент кода, который используется для: сначала сортировки списка данных на основе первого столбца Entity, второго столбца GREN и третьего столбца IC.И затем компилирование данных с одинаковыми столбцами Entity, GREN и IC.

По какой-то причине я получаю следующую ошибку при запуске кода:

Ошибка времени выполнения '1004': сбой метода 'Range' объекта '_Global'.

Это не сбой при сортировке других столбцов, и когда я использую меньше данных, кажется, что работает отлично.Кто-нибудь понимает, что идет не так?И что более важно, как это исправить?

Sub itest()

Dim EntityCol As Long, GRENCol As Long, ICCol As Long, ValueCol As Long, i As Long
Dim firstrow As Long, lastrow As Long, rngData As Range

Worksheets("FC_OUTPUT").Activate
Application.ScreenUpdating = False

EntityCol = 4 ' column D
GRENCol = 8
ICCol = 9
ValueCol = 12 ' column L
firstrow = 7
lastrow = Cells(Rows.Count, EntityCol).End(xlUp).Row

With ActiveSheet.Sort
     .SortFields.Add Key:=Range(Cells(firstrow, EntityCol)), Order:=xlAscending
     .SortFields.Add Key:=Range(Cells(firstrow, GRENCol)), Order:=xlAscending
     .SortFields.Add Key:=Range(Cells(firstrow, ICCol)), Order:=xlAscending
     .SetRange Range(Cells(firstrow, 1), Cells(lastrow, 96))
     .Header = xlNo
     .Apply
End With


Set rngData = Range(Cells(firstrow, 1), Cells(lastrow, 96)) ' this line should be adjusted but you'll need to also adjust firstrow and lastrow

With rngData
' Here I'll start a loop for every row going from the end to the beginning, to prevent issues when removing rows
    For i = lastrow To firstrow Step -1
    ' Here I'll use the If statement to check if the values are the same as the previous row

        If .Cells(i, EntityCol) = .Cells(i - 1, EntityCol) And _
                .Cells(i, GRENCol) = .Cells(i - 1, GRENCol) And _
                .Cells(i, ICCol) = .Cells(i - 1, ICCol) Then
            ' This is where you'll do your addition and delete
            .Cells(i - 1, ValueCol).Value2 = .Cells(i - 1, ValueCol) + .Cells(i, ValueCol)
            .Rows(i).Delete
        End If
    Next i
End With

End Sub

Answer 1

Вот как бы я это сделал:

Sub tgr()

    Const lEntityCol As Long = 4    'Column D
    Const lGRENCol As Long = 8      'Column H
    Const lICCol As Long = 9        'Column I
    Const lValueCol As Long = 12    'Column L
    Const lDataStartRow As Long = 7 'Actual data (not headers) starts on row 7

    Dim ws As Worksheet
    Dim rData As Range
    Dim rDel As Range
    Dim hUnq As Object
    Dim aData As Variant
    Dim sTemp As String
    Dim sDelim As String
    Dim i As Long

    Set ws = ActiveWorkbook.Worksheets("FC_OUTPUT")
    Set rData = ws.Range("A" & lDataStartRow & ":CR" & ws.Cells(ws.Rows.Count, lEntityCol).End(xlUp).Row)
    Set hUnq = CreateObject("Scripting.Dictionary")
    sDelim = "|"    'This is a character that will not be in your data

    With rData
        If .Row < lDataStartRow Then Exit Sub   'No data
        .Sort Key1:=Intersect(.Cells, ws.Columns(lEntityCol)), Order1:=xlAscending, _
              Key2:=Intersect(.Cells, ws.Columns(lGRENCol)), Order2:=xlAscending, _
              Key3:=Intersect(.Cells, ws.Columns(lICCol)), Order3:=xlAscending, _
              Header:=xlNo
        aData = .Value
    End With

    For i = LBound(aData, 1) To UBound(aData, 1)
        If Len(Trim(aData(i, lEntityCol))) > 0 _
        And Len(Trim(aData(i, lGRENCol))) > 0 _
        And Len(Trim(aData(i, lICCol))) > 0 Then
            sTemp = LCase(Trim(aData(i, lEntityCol))) & sDelim & LCase(Trim(aData(i, lGRENCol))) & sDelim & LCase(Trim(aData(i, lICCol)))
            If Not hUnq.exists(sTemp) Then
                'New unique combination of Entity, GREN, and IC found
                hUnq.Add sTemp, sTemp

                'Get the total sum of values for the unique combination
                rData.Cells(i, lValueCol).Value = WorksheetFunction.SumIfs(ws.Columns(lValueCol), _
                                                                           ws.Columns(lEntityCol), aData(i, lEntityCol), _
                                                                           ws.Columns(lGRENCol), aData(i, lGRENCol), _
                                                                           ws.Columns(lICCol), aData(i, lICCol))
            Else
                'Not a new unique combination, add it to the list of rows to be deleted
                If rDel Is Nothing Then Set rDel = rData.Cells(i, 1) Else Set rDel = Union(rDel, rData.Cells(i, 1))
            End If
        End If
    Next i

    If Not rDel Is Nothing Then rDel.EntireRow.Delete

End Sub