Отладка Excel VBA

Question

Я столкнулся с «ошибкой времени выполнения 1004». Я подозреваю, что это как-то связано с тем, сколько данных я хочу, чтобы мой код обрабатывал. В настоящее время я использую 246 столбцов на 30 000 строк. Я пытаюсь объединить мои данные в один элемент строки, потому что текущая система экспортирует данные в отдельную строку как дубликаты для определенных столбцов данных. В результате данные имеют ступенчатый / ступенчатый эффект, когда идентификатор строки дублируется с пустыми ячейками в одной и данными под ней.

Пример:

введите описание изображения здесь

Код:

Option Explicit

Sub consolidate()

    Const SHEET_NAME = "Archer Search Report"
    Const NO_OF_COLS = 101

    Dim wb As Workbook, ws As Worksheet
    Dim irow As Long, iLastRow As Long, c As Long, count As Long

    Set wb = ThisWorkbook
    Set ws = wb.Sheets(SHEET_NAME)
    iLastRow = ws.Range("A" & Rows.count).End(xlUp).Row

    ' scan up sheet
    For irow = iLastRow - 1 To 2 Step -1

         ' if same id below
        If ws.Cells(irow + 1, 1) = ws.Cells(irow, 1) Then

            ' scan across
            For c = 1 To NO_OF_COLS
                ' if blank copy from below
                If Len(ws.Cells(irow, c)) = 0 Then
                   ws.Cells(irow, c) = ws.Cells(irow + 1, c)
                End If
            Next

            ws.Rows(irow + 1).Delete
            count = count + 1

        End If

    Next

    MsgBox iLastRow - 1 & " rows scanned" & vbCr & _
           count & " rows deleted from " & ws.Name, vbInformation

End Sub

Я подозреваю, что это связано с огромным объемом данных, которые он выполняет, и хотел проверить, так ли это. Если да, то есть ли альтернативный подход? Благодарю за помощь.

Примечание. Я получил этот замечательный код от кого-то (CDP1802) и уже много лет использую его с меньшим набором данных.

Answer 1

Вот немного другой подход, который не требует сортировки по идентификатору, включает некоторую проверку значений ошибок и не перезаписывает никакие данные в выводе.

Sub consolidate()

    Const SHEET_NAME = "Archer Search Report"
    Const NO_OF_COLS = 10 'for example

    Dim wb As Workbook, ws As Worksheet, dataIn, dataOut
    Dim i As Long, c As Long
    Dim dict As Object, id, rwOut As Long, idRow As Long, vIn, vOut, rngData As Range
    
    Set wb = ThisWorkbook
    Set ws = wb.Sheets(SHEET_NAME)
    Set dict = CreateObject("scripting.dictionary")
   
    Set rngData = ws.Range("A2:A" & ws.Cells(ws.Rows.count, 1).End(xlUp).Row).Resize(, NO_OF_COLS)
    dataIn = rngData.Value  'input data as 2D array
    
    ReDim dataOut(1 To UBound(dataIn, 1), 1 To NO_OF_COLS) 'resize "out" to match "in" array size
    rwOut = 0               'row counter for "out" array
    
    For i = 1 To UBound(dataIn, 1)
        
        id = dataIn(i, 1) 'id for this "row"
        
        If Not dict.exists(id) Then
            'not seen this id before
            rwOut = rwOut + 1
            dict(id) = rwOut       'add id and row to dictionary
            dataOut(rwOut, 1) = id 'add id to "out" array
        End If
        
        idRow = dict(id)          'row locator in the "out" array
        For c = 2 To NO_OF_COLS
            vIn = dataIn(i, c)        'incoming value
            vOut = dataOut(idRow, c)  'existing value
            'ignore error values, and don't overwrite any existing value in the "out" array
            If Not IsError(vIn) Then
                If Len(vIn) > 0 And Len(vOut) = 0 Then dataOut(idRow, c) = vIn
            End If
        Next c
    Next i
    
    rngData.Value = dataOut 'replace input data with output array

    MsgBox "Got " & rwOut & " unique rows from " & UBound(dataIn, 1)

End Sub