Excel VBA Debugging

Question

I'm running into a "run time error 1004". I suspect this has something to do with how much data I want my code to process. Currently I am running a 246 column by 30,000 row. What I'm trying to achieve is to consolidate my data into one row item because the current system export the data into individual row as a duplicate for certain data columns. As a result, the data has a ladder/stagger effect where there's duplicate row ID with blank cells in one and data below it.

Example:

Code:

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

I suspect it has to do with the massive amount of data it's running and wanted to see if that is the case. If so, is there an alternative approach? Appreciate the assistance.

Note: I got this awesome code from someone(CDP1802)here and have been using it for years with smaller data set.

It's unlikely to be due to having more data. Any chance you have error values in your worksheet? — Tim Williams
– Tim Williams, Commented Jul 8, 2020 at 23:41
@TimWilliams I thought about that too. But when I tested it, error 13 was raised for type mismatch. I guess We have to wait for the exact line that's causing the error. The code is running well on my computer — Super Symmetry
– Super Symmetry, Commented Jul 9, 2020 at 0:00
What are the values of iRow and c when it fails, and what values are in those respective cells? — Tim Williams
– Tim Williams, Commented Jul 9, 2020 at 0:49

Tim Williams · Accepted Answer · 2020-07-09 00:47:37Z

Here's a slightly different approach which does not require sorting by id, includes some checking for error values, and does not overwrite any data in the output.

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

This code works!!! And it processed much faster then the current one. I'm still trying to understand it and may have questions afterwards.

Collectives™ on Stack Overflow

Excel VBA Debugging

1 Answer 1

1 Comment

Your Answer

Hot Network Questions

Collectives™ on Stack Overflow

1 Answer 1

1 Comment

Your Answer

Sign up or log in

Post as a guest

Related