Macro fails when run via remote desktop

[zzjasonzz]

Hi,

I wrote the following macro which has three ranges of workbooks (10 workbooks each) and checks whether the user has put a "y" next to any, if they have it will open up the workbook and copy the data into a database (each range has a different database).

The macro works fine when i run it from my work computer but when i use remote desktop and try run the macro from home it gives two types of errors either out of memory or clipboard full and crashes (it still works but will only upload 4-5 at a time which means i have to constantly watch it then check what was uploaded etc)

Does anyone know how to fix this error? is there a more effecient way to write the code? Is there a good way to flush the clipboard after every copy (i did a few searches and found some APIs but couldnt get them to work)

Thanks for any help,
Jason

Option Explicit

Sub UploadData()
        
On Error Resume Next
    
Application.ScreenUpdating = False
Application.DisplayAlerts = False
    
    
Dim uploadWB As Workbook
Dim reportingDB As Workbook
Dim curWB As Workbook

Dim uploadSht As Worksheet
Dim podSht As Worksheet
Dim prDB As Worksheet

Dim cnt
Dim rname
Dim ce
Dim currentteam
Dim ctfilepath
Dim uploadkey
Dim frow

Set uploadWB = ThisWorkbook
Set uploadSht = uploadWB.Sheets("Upload")

uploadSht.Range("G18:G100").ClearContents

cnt = 1
For Each rname In uploadWB.Names
    If Left(rname.Name, 4) = "Keys" Then
        If WorksheetFunction.CountIf(uploadSht.Range(rname.Name).Offset(, -2), "y") > 0 Then
            Workbooks.Open uploadSht.Range(Right(rname.Name, Len(rname.Name) - 5) & "_DB")
            Set reportingDB = ActiveWorkbook
            Set prDB = reportingDB.Sheets("Primary Reporting DB")
            '' reset upload keys
                prDB.Range("A6").Formula = "=TEXT((B6+6-WEEKDAY(B6)),""dd/mm/yyyy"")&D6&"" ""&E6"
                prDB.Range("A6").Copy Destination:=prDB.Range("A7:A" & prDB.Range("A60000").End(xlUp).Row)
                prDB.Calculate
                prDB.Range("A6:A" & prDB.Range("A60000").End(xlUp).Row).Copy
                prDB.Range("A6").PasteSpecial (xlPasteValues)
                Application.CutCopyMode = False
            
            
            For Each ce In uploadSht.Range(rname.Name)
                Application.StatusBar = "Currently uploading " & cnt & "/" & WorksheetFunction.CountIf(uploadSht.Range("B1:B100"), "y")
                If ce.Offset(, -2) = "y" Then
                    cnt = cnt + 1
                    currentteam = ce.Value
                    ctfilepath = ce.Offset(, 1).Value & "\" & ce.Offset(, 2).Value
                    
                    Workbooks.Open filename:=ctfilepath
                    Set curWB = ActiveWorkbook
                    Set podSht = curWB.Sheets("POD Weekly")
                    podSht.Calculate
                    uploadkey = podSht.Cells(76, 8) & podSht.Cells(83, 4) & " " & podSht.Cells(83, 5)
                    podSht.Range(podSht.Cells(83, 2), podSht.Cells(podSht.Range("B83").End(xlDown).Row, podSht.Range("B83").End(xlToRight).Column)).Copy
                    frow = prDB.Range("B65000").End(xlUp).Row + 1
                    prDB.Range("B" & frow).PasteSpecial (xlPasteValues)
                    prDB.Range("A" & frow & ":A" & prDB.Range("B" & frow).End(xlDown).Row) = uploadkey
                    Application.CutCopyMode = False
                    curWB.Close savechanges:=False
                    
                    If uploadSht.Cells(ce.Row, 7) = 0 Then
                        uploadSht.Cells(ce.Row, 7) = "Uploaded! - " & Now()
                    End If
                End If
            Next ce
            reportingDB.Close savechanges:=True
        End If
    End If
Next rname

uploadSht.Range("B18:B100").ClearContents
Application.ScreenUpdating = True
Application.StatusBar = False
Application.DisplayAlerts = True
    
End Sub

 

[nirvana_]

can you upload a sample file with what needs doing. thanks.