如果主工作表上的公式支持Excel VBA，则复制另一个工作表

Problem I have is, when I am saving my my worksheet as another workbook using code below I also need to copy additional worksheet only on one occasion when formulas on the worksheet I intend to save refer to the "Price List" worksheet, which I would need to also save along with the first worksheet. I hope it make sense. Also another small problem, when I save worksheet as a new workbook, I need that workbook to open imedietly, so that I can then continue to work with that workbook.

我遇到的问题是，当我使用下面的代码保存我的工作表作为另一个工作簿时，我还需要仅在一次工作表中我打算保存的公式时复制其他工作表，请参阅“价格表”工作表，我会还需要与第一个工作表一起保存。我希望它有意义。另一个小问题，当我将工作表保存为新工作簿时，我需要该工作簿以imedietly方式打开，以便我可以继续使用该工作簿。

Here is my code

这是我的代码

Private Sub UserForm_Initialize()
    Dim ws As Worksheet
    For Each ws In Worksheets
        If InStr(LCase(ws.Name), "template") <> 0 Then
            cmbSheet.AddItem ws.Name
        End If
    Next ws
End Sub
'Continue to create your invoice and check for the archive folder existance
Private Sub ContinueButton_Click()

    If cmbSheet.Value = "" Then
        MsgBox "Please select the Invoice Template from the list to continue."
    ElseIf cmbSheet.Value <> 0 Then
        Dim response
        Application.ScreenUpdating = 0
        'Creating the directory only if it doesn't exist
        directoryPath = getDirectoryPath
        If Dir(directoryPath, vbDirectory) = "" Then
            response = MsgBox("The directory " & Settings.Range("_archiveDir").Value & " does not exist. Would you like to create it?", vbYesNo)
            If response = vbYes Then
                createDirectory directoryPath
                MsgBox "The folder has been created. " & directoryPath
                Application.ScreenUpdating = False
            Else
                MsgBox "You need to create new folder " & Settings.Range("_archiveDir").Value & " to archive your invoices prior to creating them."
                GoTo THE_END
            End If
        End If
        If Dir(directoryPath, vbDirectory) <> directoryPath Then
            Sheets(cmbSheet.Value).Visible = True
        'Working in Excel 97-2007
            Dim FileExtStr As String
            Dim FileFormatNum As Long
            Dim Sourcewb As Workbook
            Set Sourcewb = ActiveWorkbook
            Dim Destwb As Workbook
            Dim TempFilePath As String
            Dim TempFileName As String
            Dim fName As String
            Dim sep As String
            sep = Application.PathSeparator

            With Application
                .ScreenUpdating = False
                .EnableEvents = False
            End With

           'Copy the sheet to a new workbook

            Sourcewb.Sheets(cmbSheet.Value).Copy
            Set Destwb = ActiveWorkbook

            'Determine the Excel version and file extension/format
            With Destwb
                If Val(Application.Version) < 12 Then
                    'You use Excel 97-2003
                    FileExtStr = ".xls": FileFormatNum = -4143
                Else
                    If Sourcewb.Name = .Name Then
                        GoTo THE_END
                    Else
                        Select Case Sourcewb.FileFormat
                        Case 51: FileExtStr = ".xlsx": FileFormatNum = 56
                        End Select
                    End If
                End If
            End With

            'Copy current colorscheme to the new Workbook
            For i = 1 To 56
                Destwb.Colors(i) = Sourcewb.Colors(i)
            Next i

            'If you want to change all cells in the worksheet to values, uncomment these lines.
            'With Destwb.Sheets(1).UsedRange
            'With Sourcewb.Sheets(cmbSheet.Value).UsedRange
            '    .Cells.Copy
            '    .Cells.PasteSpecial xlPasteValues
            '    .Cells(1).Select
            'End With
            Application.CutCopyMode = False

            'Save the new workbook and close it
            Destwb.Sheets(1).Name = "Invoice"
            fName = Home.Range("_newInvoice").Value
            TempFilePath = directoryPath & sep
            TempFileName = fName

            With Destwb
                .SaveAs TempFilePath & TempFileName, FileFormat:=FileFormatNum
                .Close SaveChanges:=False
            End With

            MsgBox "You can find the new file in " & TempFilePath & TempFileName
        End If
    End If

THE_END:

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
    Unload Me


End Sub

1 个解决方案

#1

If I'm understanding you correctly, based on what you said you need to do two things:

如果我正确地理解你，根据你所说的你需要做两件事：

• Copy a worksheet when formulas contain references to the "Price List" worksheet

  当公式包含对“价格清单”工作表的引用时，复制工作表

  

• Save the new worksheet as a new workbook and open immediately

  将新工作表另存为新工作簿并立即打开

Here is code to paste in a module:

以下是粘贴在模块中的代码：

        Sub IdentifyFormulaCellsAndCopy()

        '******** Find all cells that contain formulas and highlight any that refer to worksheet 'price list' **********

        Dim ws As Worksheet
        Dim rng As Range

        Set ws = ActiveSheet

        For Each rng In ws.Cells.SpecialCells(xlCellTypeFormulas)

            If InStr(LCase(rng.Formula), "price list") <> 0 Then

                'Highlight cell if it contains formula
                rng.Interior.ColorIndex = 36

            End If

        Next rng

        '*******************************************************************************************************************


        '********* Save worksheet as new workbook, then activate and open immediately to begin work on it *******************

        'Hide alerts
        Application.DisplayAlerts = False

        Dim FName As String
        Dim FPath As String
        Dim NewBook As Workbook

        FPath = "C:\Users\User\Desktop"
        FName = "CopiedWorksheet " & Format(Date, "yyyy-mm-dd") & ".xls"

        'Create a new workbook
        Set NewBook = Workbooks.Add

        'Copy the 'template' worksheet into new workbook
        ThisWorkbook.Sheets("template").Copy Before:=NewBook.Sheets(1)

        'If file doesn't already exist, then save new workbook
        If Dir(FPath & "\" & FName) <> "" Then
            MsgBox "File " & FPath & "\" & FName & " already exists"
        Else
            NewBook.SaveAs Filename:=FPath & "\" & FName
        End If

        'Activate workbook that you just saved
        NewBook.Activate

        'Show Alerts
        Application.DisplayAlerts = True

        '**********************************************************************************************************************

    End Sub

Notes:

笔记：

Depending on how you implement this code, you can add Application.ScreenUpdating = False to speed things up.

根据您实现此代码的方式，您可以添加Application.ScreenUpdating = False以加快速度。

Also, this code assumes that you have worksheets with the names of template and Price List.

此外，此代码假定您的工作表包含模板和价目表的名称。