Macro not working on all the way through the document

cnl83
cnl83 used Ask the Experts™
on
MacroEE.xlsmAttached is an excel 2010 document with a Macro. The macro is designed to combine multiple rows with the same employee ID and total the points. This worked the last time I used it, but on this particular document it only works up to a certain point. If you hit CTRL T it will run the macro. I can't tell where its stopping or see any inconsistencies that would cause it to not stop.

After the macro runs, we should end up with about 800-1000 records.

<<Code added by byundt--Microsoft Excel Zone Advisor 5-22-12 so question would make sense without sample workbook>>
Sub David_Macro()
'
' David_Macro Macro
' Combine Rows and Total Points
'

'
Dim RowCount As Long
Dim i As Long
Dim j As Long

'Find out how many rows have data
RowCount = ActiveSheet.Range("A:A").End(xlDown).Row

For i = 2 To RowCount
    ' If a row value in col E is the same as the next row then...
    If Range("E" & i).Value = Range("E" & i + 1).Value Then
        ' ...start looking for all rows that follow it that have the same value
        For j = i + 1 To RowCount
            If Range("E" & j).Value = Range("E" & i).Value Then
                ' We've found one that's the same so add the value in column C to the first one
                Range("C" & i).Value = Range("C" & i).Value + Range("C" & j).Value
                ' Mark the row we just used for later deletion
                Range("K" & j).Value = "DELETE"
            Else
                Exit For
            End If
        Next
        i = j - 1
    End If
Next

' Delete the marked rows
For i = RowCount To 2 Step -1
    If Range("K" & i).Value = "DELETE" Then
        Rows(i & ":" & i).Select
        Selection.Delete Shift:=xlUp
    End If
Next
End Sub

Open in new window

Comment
Watch Question

Do more with

Expert Office
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®
Any chance there is a blank  cell within column A?
NorieAnalyst Assistant
Commented:
As far as I can see it is working.

It finds all the consecutive Codes, sums the points for them and then deletes all but the first one.

Isn't that what's meant to happen?

If you want to end up with only one row per code then try sorting the data by the code before you run the code.
Hi, cnl83.

I suspect that normally this file is sorted by Code. Your problem this time is that it isn't.

Regards,
Brian.
Apologies, imnorie, crossing posts.
Mechanical Engineer
Most Valuable Expert 2013
Top Expert 2013
Commented:
I rewrote your macro to sort by column E (as imnorie and redmondb suggested). It finds 940 rows of data, and runs much faster than original macro because screen updating is off.
Sub David_Macro()
'
' David_Macro Macro
' Combine Rows and Total Points
'

Dim rg As Range
Dim RowCount As Long
Dim i As Long
Dim j As Long

Application.ScreenUpdating = False
'Find out how many rows have data
With ActiveSheet
    RowCount = .Cells(.Rows.Count, 1).End(xlUp).Row
    Set rg = Range(.Cells(, 1), .Cells(RowCount, "J"))
    rg.Sort Key1:=.Cells(1, "E"), order1:=xlAscending, Header:=xlYes, MatchCase:=False
    
    For i = 2 To RowCount
        ' If a row value in col E is the same as the next row then...
        If .Range("E" & i).Value = .Range("E" & i + 1).Value Then
            ' ...start looking for all rows that follow it that have the same value
            For j = i + 1 To RowCount
                If .Range("E" & j).Value = .Range("E" & i).Value Then
                    ' We've found one that's the same so add the value in column C to the first one
                    .Range("C" & i).Value = .Range("C" & i).Value + .Range("C" & j).Value
                    ' Mark the row we just used for later deletion
                    .Range("K" & j).Value = "DELETE"
                Else
                    Exit For
                End If
            Next
            i = j - 1
        End If
    Next
    
    ' Delete the marked rows
    For i = RowCount To 2 Step -1
        If .Range("K" & i).Value = "DELETE" Then
            .Rows(i).EntireRow.Delete
        End If
    Next
End With
End Sub

Open in new window

Do more with

Expert Office
Submit tech questions to Ask the Experts™ at any time to receive solutions, advice, and new ideas from leading industry professionals.

Start 7-Day Free Trial