Code Error Run-time error '7'

[Stephen_IV]

I received this code some time ago from the board and it worked very well for a minimal amount of data. I now have over 5000 rows and it gives me this error: Run-time error '7': Out of Memory Error. What the code is doing is it is keying off of ID Numbers in column A on Sheet1 and copying to Sheet2 if there are any duplicate it puts the duplicate on the same row with the original data. Can someone please help me! Thanks in advance! Stephen.

Sub moveitout()
Dim a, i As Long, b(), ii As Integer, n As Long, maxCol As Integer, x
a = Sheets("sheet1").Range("a1").CurrentRegion.Resize(, 13).Value
ReDim b(1 To UBound(a, 1), 1 To Columns.Count)
With CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(a, 1)
        If Not .exists(a(i, 1)) Then
            n = n + 1
            For ii = 1 To 13: b(n, ii) = a(i, ii): Next
            .Add a(i, 1), Array(n, 13)
        Else
            x = .Item(a(i, 1))
            For ii = 1 To 13: b(x(0), x(1) + ii) = a(i, ii): Next
            x(1) = x(1) + 13
            .Item(a(i, 1)) = x
            maxCol = WorksheetFunction.Max(maxCol, x(1))
       End If
    Next
End With
With Sheets("sheet2").Range("a1")
    .CurrentRegion.ClearContents
    .Resize(n, maxCol).Value = b
End With
End Sub