Question

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

这是我的代码

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

Answer 1

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

当公式包含对＆＃34;价格表＆＃34;的引用时复制工作表工作表
将新工作表另存为新工作簿并立即打开

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

        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

备注：

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

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

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

1 个答案: