Excel VBA Error on Copy to Different Excel

qwewer

New Member
Joined
May 2, 2022
Messages
3
Office Version
  1. 365
  2. 2021
Platform
  1. Windows
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:
VBA 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:
VBA 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
 

Excel Facts

How to create a cell-sized chart?
Tiny charts, called Sparklines, were added to Excel 2010. Look for Sparklines on the Insert tab.

Alex Blakenburg

MrExcel MVP
Joined
Feb 23, 2021
Messages
4,085
Office Version
  1. 365
Platform
  1. Windows
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:
VBA Code:
    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
 
Solution

qwewer

New Member
Joined
May 2, 2022
Messages
3
Office Version
  1. 365
  2. 2021
Platform
  1. Windows
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

MrExcel MVP
Joined
Feb 23, 2021
Messages
4,085
Office Version
  1. 365
Platform
  1. Windows
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

New Member
Joined
May 2, 2022
Messages
3
Office Version
  1. 365
  2. 2021
Platform
  1. Windows
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:
VBA 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

MrExcel MVP
Joined
Feb 23, 2021
Messages
4,085
Office Version
  1. 365
Platform
  1. Windows
Thanks for letting me know and showing your final code. Glad I could help.
 
Master Excel Bundle

Excel contains over 450 functions, with more added every year. That’s a huge number, so where should you start? Right here with this bundle.

Forum statistics

Threads
1,167,809
Messages
5,855,763
Members
431,760
Latest member
IceAg08

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top