ActiveSheet.Paste Link:= True Does Not Work After Awhile - 1004 MS Excel cannot paste data

Hi,

check if this works for you, sorry for changing so much but you had a lot of selects there: Sample Disposition 06-25-13_edit.xlsm

contains:

Option Explicit

Sub Macro1()
    Dim xlWsSrc As Worksheet, xlWsNew As Worksheet
    Dim xlRng As Range
    Dim CoName As String
    Dim sgnStart As Single
    Dim LastRow As Long, RowNum As Long, CoRowNum As Long, i As Long
    Dim LastCol As Integer, Attempt As Integer, j As Integer
    
    On Error GoTo Macro1_ErrorHandler
    Application.ScreenUpdating = False

    Set xlWsSrc = Worksheets("Sheet1")

    ' Find last row for the loop.
    LastRow = GetLastRow(xlWsSrc)

    ' Find last column for the Disposition code.
    LastCol = GetLastCol(xlWsSrc)

    With xlWsSrc
        'data validation
        With Union(.Range(.Cells(2, LastCol + 1), .Cells(LastRow, LastCol + 1)), _
                          .Range(.Cells(2, LastCol + 4), .Cells(LastRow, LastCol + 4)), _
                          .Range(.Cells(2, LastCol + 7), .Cells(LastRow, LastCol + 7)), _
                          .Range(.Cells(2, LastCol + 10), .Cells(LastRow, LastCol + 10)), _
                          .Range(.Cells(2, LastCol + 13), .Cells(LastRow, LastCol + 13)), _
                          .Range(.Cells(2, LastCol + 16), .Cells(LastRow, LastCol + 16)), _
                          .Range(.Cells(2, LastCol + 19), .Cells(LastRow, LastCol + 19)), _
                          .Range(.Cells(2, LastCol + 22), .Cells(LastRow, LastCol + 22)), _
                          .Range(.Cells(2, LastCol + 25), .Cells(LastRow, LastCol + 25))).Validation


            .Delete
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="=dc"
            
        End With

        'borders:
        For j = 1 To 25 Step 3
            With .Range(.Cells(1, LastCol + j), .Cells(LastRow, LastCol + j + 2))
                For i = 7 To 10
                    .Borders(i).Weight = xlThick
                Next i
            End With
        Next j

        'headings
        j = LastCol
        For Attempt = 1 To 9
            .Cells(1, j + 1).Value = "ATT" & Attempt
            .Cells(1, j + 2).Value = "Date" & Attempt
            .Cells(1, j + 3).Value = "Notes" & Attempt
            j = j + 3
        Next Attempt
        Attempt = Attempt - 1
        
        
        ' Sample starts on row #2.
        ' Copy the rows to the separate worksheets.
        LastCol = GetLastCol(xlWsSrc)   'new last col
        For i = 2 To LastRow
            CoName = GetValidWsName(.Cells(i, 6).Value)
            If Not XL_WsExists(CoName) Then      'if new company
                .Parent.Worksheets.Add(After:=(.Parent.Worksheets(.Parent.Worksheets.Count))).Name = CoName
                Set xlWsNew = .Parent.Worksheets(.Parent.Worksheets.Count)
                .Rows(1).Copy Destination:=xlWsNew.Rows(1)   'copy header to new sheet
            End If
            If xlWsNew Is Nothing Then Set xlWsNew = .Parent.Worksheets(CoName)
            CoRowNum = GetLastRow(xlWsNew) + 1
            .Range(.Cells(i, 1), .Cells(i, LastCol)).Copy Destination:=xlWsNew.Cells(CoRowNum, 1)
            
            For j = 1 To LastCol
                .Cells(i, j).Formula = "='" & CoName & "'!" & xlWsNew.Cells(CoRowNum, j).Address
            Next j
            
        Next i
        
        .Activate
        .Cells(1, 1).Select
        
    End With

Macro1_Proc_Exit:
    On Error GoTo 0
    Set xlWsSrc = Nothing
    Set xlWsNew = Nothing
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    Exit Sub
Macro1_ErrorHandler:
    MsgBox "Error: " & Err.Number & " (" & Err.Description & ") in Sub 'Macro1' of Module 'Module1'.", vbOKOnly + vbCritical, "Error"
    Resume Macro1_Proc_Exit
  
End Sub

Function GetLastRow(Optional ByVal xlws As Excel.Worksheet, Optional ByVal iCol As Integer) As Integer
    On Error GoTo ErrorHandler
    Dim xlRng As Range
    If xlws Is Nothing Then Set xlws = ActiveSheet
    If iCol = 0 Then Set xlRng = xlws.Cells Else Set xlRng = xlws.Columns(iCol)
    With xlRng
        GetLastRow = .Find(What:="*", After:=.Cells(.Rows.Count, .Columns.Count), LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row
    End With
    Exit Function
ErrorHandler:
    GetLastRow = 0
End Function

Function GetLastCol(Optional ByVal xlws As Excel.Worksheet, Optional ByVal iRow As Long) As Long
    On Error GoTo ErrorHandler
    Dim xlRng As Range
    If xlws Is Nothing Then Set xlws = ActiveSheet
    If iRow = 0 Then Set xlRng = xlws.Cells Else Set xlRng = xlws.Rows(iRow)
    With xlRng
        GetLastCol = .Find(What:="*", After:=.Cells(.Rows.Count, .Columns.Count), LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False).Column
    End With
    Exit Function
ErrorHandler:
    GetLastCol = 0
End Function

Function GetValidWsName(ByVal wsName As String) As String
    Const INVALID_CHARS As String = ":\/?*[]"
    Dim i As Byte
    GetValidWsName = wsName
    For i = 1 To Len(INVALID_CHARS)
        GetValidWsName = Replace$(GetValidWsName, Mid(INVALID_CHARS, i, 1), vbNullString)
    Next
    GetValidWsName = Left$(GetValidWsName, 31)
End Function

Function XL_WsExists(ByVal wsName As String, Optional xlWb As Excel.Workbook) As Boolean
    On Error Resume Next
    Dim xlws As Worksheet
    If xlWb Is Nothing Then Set xlWb = ActiveWorkbook
    Set xlws = xlWb.Worksheets(wsName)
    XL_WsExists = (Err.Number = 0)
    Set xlws = Nothing
End Function

Hi,

does it crash on the sample file or another?
Is there an error message?
If yes whats the error code and the description?
Can you debug it to find out in which codeline/row it happens?

Make sure column F is not blank, otherwise you'll get error 1004: Application defined or object defined error.