SaveCopyAs

Hi there,

I don't think it's possible to save individual sheets of a workbook, but what you CAN do is to create a new workbook containing only the sheets you need & then save that workbook.

To do this, replace your code:

         Application.EnableEvents = False
         ActiveWorkbook.SaveCopyAs Filename:="C:\Data\" & _
         Replace(ActiveWorkbook.Name, ".xls", _
         " " & Format(Now, "yyyy-mm-dd-hh-mm") & ".xls")
         Application.EnableEvents = True

with

Call SaveWorkbook

and insert the following subroutine in your VBA module:

Option Explicit


Sub SaveWorkbook()

    Dim strDummyName    As String
    Dim arySheets       As Variant
    Dim strSheet        As Variant
    Dim wbk             As Workbook
    Dim sht             As Worksheet

    arySheets = Array("Sheet1", "Sheet2")

    On Error GoTo EnableAlerts

'       The next line is just a unique sheetname - it can be anything!
        strDummyName = "Ax2395EF"

        Workbooks.Add
        Set wbk = ActiveWorkbook

        Application.DisplayAlerts = False
            Do While wbk.Sheets.Count > 1
                wbk.Sheets(1).Delete
            Loop
        Application.DisplayAlerts = True
        wbk.Sheets(1).Name = strDummyName
        
        For Each strSheet In arySheets
            ThisWorkbook.Sheets(strSheet).Copy After:=wbk.Sheets(wbk.Sheets.Count)
        Next strSheet

        Application.DisplayAlerts = False
            wbk.Sheets(strDummyName).Delete
        Application.DisplayAlerts = True

        Application.EnableEvents = False
            On Error Resume Next
                wbk.SaveAs Filename:="C:\Data\" & _
                           Replace(ThisWorkbook.Name, ".xls", " " & _
                           Format(Now, "yyyy-mm-dd-hh-mm") & ".xls")
                If Err.Number <> 0 Then
                    On Error GoTo 0
                    MsgBox "Error encountered during ""Save"" operation - " & _
                           "the new workbook has NOT been saved", _
                            vbCritical, "Workbook not saved"
                    GoTo EnableAlerts
                End If
            wbk.Close SaveChanges:=False


EnableAlerts:

    Application.EnableEvents = False
    Application.DisplayAlerts = True

End Sub

Note that the statement:

    arySheets = Array("Sheet1", "Sheet2")

contains the names of the sheets you want to include in the new workbook.

The routine works by creating a new workbook, deleting all of its worksheets except one (a workbook must contain at least one worksheet) & then renaming that worksheet with a unique "rubbish" name (just to avoid any conflict with the sheetnames in your source workbook.)

The routine then copies the specified worksheets (in the specified order) from the source workbook to the new workbook, and then deletes the worksheet with the "rubbish" name.

Finally, the new workbook is saved using your existing naming convention & is then closed.

Hope this helps - please let me know how you get on.

Best regards,

Greg M

Greg,
Thanks for your quick responce. The code below is what I have now. It works great, but will only run one time. If I open the workbook and put a value into a cell which causes cell H1 to result in a value of 1, the code runs and saves a copy just like we want it to. If I return to the sheet with the code and toggle the H1 cell value back to 0 and 1 agian, the code does not appear to run.

Thanks, Kevin

Option Explicit


Sub SaveWorkbook()

    Dim strDummyName    As String
    Dim arySheets       As Variant
    Dim strSheet        As Variant
    Dim wbk             As Workbook
    Dim sht             As Worksheet

    arySheets = Array("Sheet2", "Sheet3")

    On Error GoTo EnableAlerts

'       The next line is just a unique sheetname - it can be anything!
        strDummyName = "Blank"

        Workbooks.Add
        Set wbk = ActiveWorkbook

        Application.DisplayAlerts = False
            Do While wbk.Sheets.Count > 1
                wbk.Sheets(1).Delete
            Loop
        Application.DisplayAlerts = True
        wbk.Sheets(1).Name = strDummyName
        
        For Each strSheet In arySheets
            ThisWorkbook.Sheets(strSheet).Copy After:=wbk.Sheets(wbk.Sheets.Count)
        Next strSheet

        Application.DisplayAlerts = False
            wbk.Sheets(strDummyName).Delete
        Application.DisplayAlerts = True

        Application.EnableEvents = False
            On Error Resume Next
                wbk.SaveAs Filename:="C:\Data\" & _
                           Replace(ThisWorkbook.Name, ".xls", " " & _
                           Format(Now, "yyyy-mm-dd-hh-mm") & ".xls")
                If Err.Number <> 0 Then
                    On Error GoTo 0
                    MsgBox "Error encountered during ""Save"" operation - " & _
                           "the new workbook has NOT been saved", _
                            vbCritical, "Workbook not saved"
                    GoTo EnableAlerts
                End If
            wbk.Close SaveChanges:=False


EnableAlerts:

    Application.EnableEvents = False
    Application.DisplayAlerts = True

End Sub

Private Sub Worksheet_Calculate()

  Dim Inrange As Range
  Dim rng As Range
  Set Inrange = Range("H1")
  For Each rng In Inrange.Cells
    If Not IsError(rng.Value) Then
       If Me.Range("H1").Value = "1" Then
         MsgBox "Saving a Dated Copy...."
         Call SaveWorkbook
       End If
    End If
  Next rng
  
End Sub

Hi again Kevin,

Two errors - a stupid one on my part & another (not so stupid?) one on yours.

Mine first. The very last part of my code should read:

EnableAlerts:

    Application.EnableEvents = True
    Application.DisplayAlerts = True

End Sub

The previous version had EnableEvents set to False - quite wrong!

On your side, the first line of your code should read:

Private Sub Worksheet_Change(ByVal Target As Range)

This ensures that the routine is triggered whenever a cell value is CHANGED - the "WorkSheet_Calculate" event is triggered whenever the worksheet is RECALCULATED - just changing a cell value may not force a recalculation.

Anyway, hope the above helps - thanks for your feedback.

Regards,

Greg M

Greg,
If calling me stupid is the price I have to pay for your programming advice, then Fire Away! If I would have paid more attention, it would be pretty obvious that events won't work unless they are enabled. So, now it works! Thank you. And I used the Worksheet_Calculate event because the data is populating the cell from an OPC server. I tried the Worksheet_Change first, but it will only work if the cell is selected and changed. Thanks again...

Hi again Kevin,

Glad to hear that all's working fine now & happy to have helped out.

Many thanks for the feedback & best regards,

Greg