2013 Version Crashes on VBA Table Entry

[leryt]

The VBA code works well in excel 2010. My computer was updated with a 2013 and now the code always crashes in one area. I have received out of range errors to catastrophic errors. I am uncertain of how to fix it as I have attempted every other approach.

Error Details
So I have several tables set up in my excel sheets. I am trying to grab a unique number and have it paste to a table at the end. The table is filled with formulas and rely on the unique number to move through the process. The problem arises when I set the variable to be applied to the table.

I have Dimmed Initacct as string:
Dim initacct As String

When I walk through the code it initacct is defined appropriately and I can see the ID number.
When removing the last digit for my pinitacct string it also works.
Also if Dptlist.Range("$A$2").Value = "" it will also pass and apply initacct without any errors.
It is on my else statement that this crashes on the code: Dptlist.Range("A" & lrow) = initacc

Please help. Original code below.

Private Sub Userform_Initialize()
'Clear
'Extract
'NewLine
 
'Reviewed and cleaned
'pending error handle
 
Dim wb As Workbook
Dim crit, Datasrc, Dptlist, Datastat, ptlist As Worksheet
Dim SourceDept, deptlook, tbltwo, tblone, plist, StatY, PtA, DepA As Range
Dim Dept, initacct, pinitacct As String
Dim i, c, dI, pI, j As Integer
Dim lrow, prow As Long
Dim TblTwoOb As ListObject
 
'Workbook
Set wb = ThisWorkbook
    wb.Activate

'Sheets
Set crit = Sheet8
Set Datasrc = Sheet1
Set Dptlist = Sheet5
Set Datastat = Sheet6
Set ptlist = Sheet2
'Ranges
Set SourceDept = Datasrc.Range("SourceD")
Set tbltwo = Dptlist.Range("Table2[#All]")
Set tblone = ptlist.Range("Table1[#All]")
Set PtA = ptlist.Range("$A$2")
Set DepA = Dptlist.Range("$A$2")
'Objects
Set TblTwoOb = Dptlist.ListObjects("Table2")
'String
Dept = crit.Range("$A$2").Value
 
Application.ScreenUpdating = False

'On Error Resume Next
wb.Activate
Me.Label64 = Dept
 
'extract new accounts from list
For Each deptlook In SourceDept
    If deptlook.Value = Dept Then
        lrow = Dptlist.Cells(Rows.Count, 1).End(xlUp).Row + 1
        prow = ptlist.Cells(Rows.Count, 1).End(xlUp).Row + 1
            initacct = deptlook.Offset(0, -2).Value
            pinitacct = Left(initacct, Len(initacct) - 1)
                If Dptlist.Range("$A$2").Value = "" Then
                    Dptlist.Range("$A$2").NumberFormat = "@"
                    Dptlist.Range("$A$2") = initacct
                        Else
                            Dptlist.Range("A" & lrow).NumberFormat = "@"
                            'ERROR HAPPENS BELOW but not on pinitacct
                            Dptlist.Range("A" & lrow) = initacct
                End If
                If ptlist.Range("A2").Value = "" Then
                    ptlist.Range("A2").NumberFormat = "@"
                    ptlist.Range("A2") = pinitacct
                        Else
                            ptlist.Range("A" & prow).NumberFormat = "@"
                            ptlist.Range("A" & prow) = pinitacct
                End If
    End If
Next deptlook
 
'MORE CODE BELOW