Need VBA code for open workbook - If already open, then activate

[Haahr87]

Hi all,


I am completely new here.
I have looked over the forum and I have found posts, that related to what I am looking for assistance with.
However I cannot get the solutions to work for me.
Question:
I have the below VBA code and it works a charm - It could probably be simpler, but it works for my need, so it is all good.
I do however meet an issue. When the user already have the "Trykktape NO" workbook open, the user is asked, if they want t reopen it.
I am looking for a piece of code that will:
- Open the workbook "Tykktape NO"
- If the workbook is already open, then activate it
- Then runs the rest of my code
I know this is probably the simplest thing, but I cannot figure this out for the life of me.
Can anyone assist with a piece of code, that I can simply copy into my own?
Thank you very much in advance.

Best Regards
Jonas

Sub CopyAndPasteData2()
    Dim wbk As Workbook
    
    'strFirstFile = "C:\Users\andejon\Desktop\New ordersheet.xlsm"
    strSecondFile = "Q:\Operations\Customer Service\Order handling\Trykktape NO.xlsm"
    
    Sheets("Calculations").Range("H3:L3").Copy
         
    Set wbk = Workbooks.Open(strSecondFile)
    With wbk.Sheets("Trykktape Norge")
        Dim BlankRow As Long
        BlankRow = Range("A65536").End(xlUp).Row + 1
        Cells(BlankRow, 1).Select
        ActiveCell.Value = Date
        ActiveCell.Offset(0, 1).Select
        ActiveCell.Value = "New"
        ActiveCell.Offset(0, 1).Select
        ActiveCell.PasteSpecial xlPasteValues
        ActiveCell.Offset(0, 5).Select
        ActiveCell.Value = "Afventer proof"
        ActiveCell.Offset(0, 1).Select
        ActiveCell.Value = "Afventer LogoTape"
        ActiveCell.Offset(0, 1).Select
        ActiveCell.Value = "Sendt " & Date
        ActiveCell.Offset(0, -7).Select
    End With
    
    Workbooks("Trykktape NO").Save
    'Workbooks("Trycktape överblik - SE").Close
        
    Workbooks("New ordersheet.xlsm").Activate
    Application.Dialogs(xlDialogSendMail).Show Range("Calculations!E2"), Range("Calculations!E6")
        
End Sub

 

[gallen]

Hello and welcome.

You just need to attempt to set wbk to the file. If it isn't open you will get an error, which tells you it needs opening. This code will achieve it.

Not tested though so let me know if you hit any snags

Sub CopyAndPasteData2()
    Dim wbk As Workbook
    Dim strFileName As String, strFilePath As String
    
    
    'strFirstFile = "C:\Users\andejon\Desktop\New ordersheet.xlsm"
    strFilePath = "Q:\Operations\Customer Service\Order handling\"
    strFileName = "Trykktape NO.xlsm"
    strsecondFile = strFilePath & strFileName
    
    Sheets("Calculations").Range("H3:L3").Copy
    
    'ignore errors
    On Error Resume Next
    'attempt to set the variable to an open workbook.
    Set wbk = Workbooks(strFileName)
    'If wbk is nothing then the previous line failed so workbook isn't open
    If wbk Is Nothing Then
        Set wbk = Workbooks.Open(strsecondFile) 'open file
    End If
    'if wbk is still nothing then it doesn't exist
    If wbk Is Nothing Then
        MsgBox strsecondFile & " not found", vbCritical, "Not Found"
        Exit Sub
    End If
    'Don't ignore errors
    On Error GoTo 0
    


    
    With wbk.Sheets("Trykktape Norge")
        Dim BlankRow As Long
        BlankRow = Range("A65536").End(xlUp).Row + 1
        Cells(BlankRow, 1).Select
        ActiveCell.Value = Date
        ActiveCell.Offset(0, 1).Select
        ActiveCell.Value = "New"
        ActiveCell.Offset(0, 1).Select
        ActiveCell.PasteSpecial xlPasteValues
        ActiveCell.Offset(0, 5).Select
        ActiveCell.Value = "Afventer proof"
        ActiveCell.Offset(0, 1).Select
        ActiveCell.Value = "Afventer LogoTape"
        ActiveCell.Offset(0, 1).Select
        ActiveCell.Value = "Sendt " & Date
        ActiveCell.Offset(0, -7).Select
    End With
    
    Workbooks("Trykktape NO").Save
    'Workbooks("Trycktape överblik - SE").Close
        
    Workbooks("New ordersheet.xlsm").Activate
    Application.Dialogs(xlDialogSendMail).Show Range("Calculations!E2"), Range("Calculations!E6")
        
End Sub

 

[Haahr87]

Hi Gallen,,

Thank you for the very quick reply - It worked a charm!

Follow-up question:
The workbook is shared, so multiple users can work in it at the same time.
Therefore the process would be to save the sheet, before entering any date (to make sure you have the latest version).
I tried to enter: "Workbooks("Trykktape NO").Save" in the next line after the "On Error Goto 0" - But then I got an error.
Should I do something differently?

Best Regards
Jonas

 

[gallen]

Maybe lost in translation but you can't have multiple users working on a workbook at the same time. They can view it (read only) but only one person can make changes at any one time.

With regards to saving you have a variable - wbk so you'd just use

wbk.save

, that said your code is missing the file extension so should read

[COLOR=#333333]Workbooks("Trykktape NO[/COLOR][COLOR=#ff0000].xlsm[/COLOR][COLOR=#333333]").Save[/COLOR]

or even

[COLOR=#333333]Workbooks(strFileName[/COLOR][COLOR=#333333]).Save[/COLOR]

 

[Haahr87]

Hi again,

Where do I enter the "wbk.save"
I have tried to enter it after "On Error GoTo 0" and before "With wbk.Sheets("Trykktape Norge")

But I get this error:
Run-time error '1004':
Application-defined or object-defined error

Sub CopyAndPasteData3()
    Dim wbk As Workbook
    Dim strFileName As String, strFilePath As String
    
    
    'strFirstFile = "C:\Users\andejon\Desktop\New ordersheet.xlsm"
    strFilePath = "Q:\Operations\Customer Service\Order handling\"
    strFileName = "Trykktape NO.xlsm"
    strsecondFile = strFilePath & strFileName
    
    Sheets("Calculations").Range("H3:L3").Copy
    
    'ignore errors
    On Error Resume Next
    'attempt to set the variable to an open workbook.
    Set wbk = Workbooks(strFileName)
    'If wbk is nothing then the previous line failed so workbook isn't open
    If wbk Is Nothing Then
        Set wbk = Workbooks.Open(strsecondFile) 'open file
    End If
    'if wbk is still nothing then it doesn't exist
    If wbk Is Nothing Then
        MsgBox strsecondFile & " not found", vbCritical, "Not Found"
        Exit Sub
    End If
    'Don't ignore errors
    On Error GoTo 0
    
    
    wbk.Save
    With wbk.Sheets("Trykktape Norge")
        Dim BlankRow As Long
        BlankRow = Range("A65536").End(xlUp).Row + 1
        Cells(BlankRow, 1).Select
        ActiveCell.Value = Date
        ActiveCell.Offset(0, 1).Select
        ActiveCell.Value = "New"
        ActiveCell.Offset(0, 1).Select
        ActiveCell.PasteSpecial xlPasteValues
        ActiveCell.Offset(0, 5).Select
        ActiveCell.Value = "Afventer proof"
        ActiveCell.Offset(0, 1).Select
        ActiveCell.Value = "Afventer LogoTape"
        ActiveCell.Offset(0, 1).Select
        ActiveCell.Value = "Sendt " & Date
        ActiveCell.Offset(0, -7).Select
    End With
    
    Workbooks("Trykktape NO.xlsm").Save
    'Workbooks("Trycktape överblik - SE").Close
        
    Workbooks("New ordersheet.xlsm").Activate
    Application.Dialogs(xlDialogSendMail).Show Range("Calculations!E2"), Range("Calculations!E6")
        
End Sub

 

[gallen]

I've tested setting wbk to an open file, and saving and have no issue. Only issue I can see is if it is somehow read-only? But then it would just ask you to save with different name.

It won't get to wbk.Save unless wbk is set so I'm a little confused. Maybe someone else can see the error?