如果主工作表上的公式被复制到Excel VBA中，请复制另一个工作表

我的问题是，当我将我的工作表另存为使用下面的代码的另一个工作簿时，我还需要一次性复制其他工作表，当我打算保存工作表上的公式时，请参阅“价目表”工作表，我将还需要保存第一张工作表。 我希望这是有道理的。 还有一个小问题，当我将工作表保存为一个新的工作簿时，我需要该工作簿打开，以便我可以继续使用该工作簿。

这是我的代码

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

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

• 公式包含对“价目表”工作表的引用时复制工作表

  

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

这里是代码粘贴到模块中：

  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来加快速度。

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