Excel VBA Error on Copy to Different Excel

[qwewer]

Dear MrExcel Users,

I wrote a macro, that copy and pates a few ranges to a different excel file on every save of the source file,
with these criteria:

• The destination file isn't open and it needs to be saved and closed after the procedure. (done?)
• Display a message if the destination file is currently opened by another user. (done?) (or even display the other users name?)
• Paste the data (in the destination excel), next to the cell that contains the same date as in the source F1 cell. (done?)
• Paste only the values without any formatting. (done?)
• The operation should succeed every time even on consecutive savings, when the source file isn't closed in between. (not working)

But, right now it gives the following error: Run-time error '91': Object variable or With block variable not set

I couldn't find any solution to my problem, so any help would be greatly appreciated!

Thanks in advance.

Main code:

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    
    'Destination excel
    Dim WriteWB As String
    WriteWB = "C:\Users\Users\Documents\WriteFile.xlsb"
    
    If IsFileOpen(WriteWB) = False Then
    
        Application.ScreenUpdating = False
        
        Workbooks.Open "C:\Users\Users\Documents\WriteFile.xlsb"
        
        'Source excel
        Dim ReadWS As Worksheet
        Set ReadWS = ThisWorkbook.Worksheets("Sheet1")
        
        'Date in F1 cell
        Dim DateString As String
        DateString = Format(ReadWS.Range("F1").Value, "yyyy.mm.dd")
        
        'Get the cell next to the date at A:A column and Copy to destination
        ReadWS.Range("A2:E2").Copy
        Workbooks("WriteFile.xlsb").Worksheets("Sheet1").Range( _
        Workbooks("WriteFile.xlsb").Worksheets("Sheet1").Range("A:A").Find(What:=DateString).Offset(rowOffset:=0, columnOffset:=1).Address).PasteSpecial xlPasteValues
        
        ReadWS.Range("G2:K2").Copy
        Workbooks("WriteFile.xlsb").Worksheets("Sheet2").Range( _
        Workbooks("WriteFile.xlsb").Worksheets("Sheet2").Range("A:A").Find(What:=DateString).Offset(rowOffset:=0, columnOffset:=1).Address).PasteSpecial xlPasteValues
        
        'Remove copy outline in source file
        Application.CutCopyMode = False
        
        'Save and close destination file
        Workbooks("WriteFile.xlsb").Save
        Workbooks("WriteFile.xlsb").Close
        
        Application.ScreenUpdating = True
    
    Else
    
        MsgBox ("Cannot backup data, try later")
    
    End If
    
End Sub

Helper code:

Function IsFileOpen(fileName As String)

    Dim fileNum As Integer
    Dim errNum As Integer

    'Allow all errors to happen
    On Error Resume Next
    fileNum = FreeFile()

    'Try to open and close the file for input.
    'Errors mean the file is already open
    Open fileName For Input Lock Read As #fileNum
    Close fileNum

    'Get the error number
    errNum = Err

    'Do not allow errors to happen
    On Error GoTo 0

    'Check the Error Number
    Select Case errNum

        'errNum = 0 means no errors, therefore file closed
        Case 0
        IsFileOpen = False
     
        'errNum = 70 means the file is already open
        Case 70
        IsFileOpen = True

        'Something else went wrong
        Case Else
        IsFileOpen = errNum

    End Select

End Function

 

[Alex Blakenburg]

The most likely issue is that it is not finding the date you are looking up.
I am tending to use Match to find dates since they are much more tolerant to variations is date formats.

For testing I have defined your destination worksheet. I would replace this line
WriteWS.Range(WriteWS.Range("A:A").Find(What:=DateString). _ Offset(rowOffset:=0, columnOffset:=1).Address).PasteSpecial xlPasteValues

With something more like this:

    Dim dateRow As Long
    dateRow = Application.IfError(Application.Match(ReadWS.Range("F1"), WriteWS.Range("A:A"), 0), 0)

    If dateRow <> 0 Then
        MsgBox "found on row: " & dateRow
        WriteWS.Range("B" & dateRow).PasteSpecial xlPasteValues
    Else
        MsgBox "not found"
    End If

 

[qwewer]

Thank you for the quick response, but the suggested code gives me Run-time error '424": Object required on this row:

dateRow = Application.IfError(Application.Match(ReadWS.Range("F1"), WriteWS.Range("A:A"), 0), 0)

As an extra information, just now got an interesting result:
Every time I press the reset button (Alt+F11), the code is able to run successfully on save, but only once. (after that it gives the original error)

 

[Alex Blakenburg]

I have logged off for the night (I am in Australia).
You need to Dim WriteWS as Worksheet
And set WriteWS once to Sheet1 for the first paste and then to Sheet2 for the 2nd paste

 

[qwewer]

I have logged off for the night (I am in Australia).
You need to Dim WriteWS as Worksheet
And set WriteWS once to Sheet1 for the first paste and then to Sheet2 for the 2nd paste

Misunderstood your first comment. It is working now with your second comment.

Thank you for the help!

Working code:

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    
    'Destination excel
    Dim FileName As String
    FileName = "C:\Users\Users\Documents\WriteFile.xlsb"
    
    If IsFileOpen(FileName) = False Then
        
        Application.ScreenUpdating = False
        
        Workbooks.Open FileName
        
        'Destination excel
        Dim WriteWS As Worksheet
        
        'Source excel
        Dim ReadWS As Worksheet
        Set ReadWS = ThisWorkbook.Worksheets("Sheet1")
        
        Dim dateRow As Long
        
        Set WriteWS = Workbooks("WriteFile.xlsb").Worksheets("Sheet1")
        
        dateRow = Application.IfError(Application.Match(ReadWS.Range("F1"), WriteWS.Range("A:A"), 0), 0)
    
        If dateRow <> 0 Then
            ReadWS.Range("A2:E2").Copy
            WriteWS.Range("B" & dateRow).PasteSpecial xlPasteValues
        Else
            MsgBox ("not found")
        End If
        
        Set WriteWS = Workbooks("WriteFile.xlsb").Worksheets("Sheet2")
        
        dateRow = Application.IfError(Application.Match(ReadWS.Range("F1"), WriteWS.Range("A:A"), 0), 0)
    
        If dateRow <> 0 Then
            ReadWS.Range("A2:E2").Copy
            WriteWS.Range("B" & dateRow).PasteSpecial xlPasteValues
        Else
            MsgBox ("not found")
        End If
        
        'Remove copy outline in source file
        Application.CutCopyMode = False
        
        'Save and close destination file
        Workbooks("WriteFile.xlsb").Save
        Workbooks("WriteFile.xlsb").Close
        
        Application.ScreenUpdating = True
    
    Else
    
        MsgBox ("Cannot backup data, try later")
    
    End If
    
End Sub

 

[Alex Blakenburg]

Thanks for letting me know and showing your final code. Glad I could help.