Macro stops working on row

Please look at the attached sheet. I got some help in this forum earlier (http://www.excelforum.com/excel-prog...-column-c.html) and the code i got worked at first, but when i changed the sheet (added columns) and attempted to alter the code accordingly, now the code stops working at line 222.

I can't tell anything different about the data on lines 223 and so forth that would cause the macro to stop running there, maybe someone with more experience will notice?


Sheet1 is the original data. Sheet2 is after the code has been run. The item descriptions have been removed.

Option Explicit

Sub SortRows()
Dim Rng As Range, Dn As Range, n As Long, ac As Integer
Set Rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
ReDim ray(1 To Rng.Count, 1 To 14)
With CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
For Each Dn In Rng

If Dn.Offset(, 9) = "530" Or Dn.Offset(, 9) = "540" Then
If Not .Exists(Dn.Value & Dn.Next.Value & Dn.Offset(, 9)) Then
n = n + 1
.Add Dn.Value & Dn.Next.Value & Dn.Offset(, 9), n
For ac = 1 To 14
If ac = 12 Then
ray(n, ac) = Format(Dn.Offset(, ac - 1), "mm/dd/yyyy")
Else
ray(n, ac) = Dn.Offset(, ac - 1)
End If
Next ac
End If
End If
Next
Sheets("Sheet2").Range("A2").Resize(.Count, 14) = ray
End With

End Sub

Hello smokebreak,

The code is designed to only copy unique values from sheet to the other. Currently, there are only 221 unique entries on "Sheet1".

Hello smokebreak,

Don't start another thread. Leave this one open. What is the macro not doing now that it seemed to be doing before (since you marked the previous post solved)?

another way with a Collection

Option Explicit
Sub ptest()
    Dim Unqiue As New Collection, cell As Range, pInt, x, y, z, v
    For Each cell In Range("D1", Range("D" & Rows.Count).End(xlUp))
        Unqiue.Add cell.Offset(0, -3).Value & "," & cell.Offset(0, -2).Value & "," & cell.Offset(0, -1).Value & "," & _
                   cell.Value & "," & cell.Offset(0, 1).Value, CStr(cell.Value)
        On Error Resume Next
    Next cell
    x = 1
    For pInt = 1 To Unqiue.Count
        y = 1
        For Each z In Split(Unqiue.Item(pInt), ",")
            Sheets("Sheet3").Cells(x, y).Value = z
            y = y + 1
        Next
        x = x + 1
    Next
End Sub

But alas the data has changes since the origonal closed post