Question

我想创建一个VBA代码，将工作簿复制到一个单独的工作簿（workbook2）中，然后在第二个工作簿中将所有公式转换为值，因此不应在工作簿1（活动的工作簿）中进行转换。我找到了执行转换的代码，但是我不知道如何在工作簿2中执行它。然后，我应该保存该工作簿2。有什么想法吗？代码下方

Sub ConvertFormulasToValuesAllWorksheets()
On Error Resume Next
    Dim ws As Worksheet, rng As Range



    For Each ws In ActiveWorkbook.Worksheets

    For Each rng In ws.UsedRange

        If rng.HasFormula Then

            rng.Formula = rng.Value

        End If

    Next rng

    Next ws

    ActiveWorkbook.SaveAs Filename:= _
    "C:\Users\myusid\Desktop\myfolder\workbook2.xlsx" _
     , FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False ' need to 
     change the name of the folder
     Application.DisplayAlerts = True


      On Error GoTo 0
      End Sub

谢谢。

Answer 1

这是另一种方法，可让您灵活地设置变量中的文件名和路径。

还有一些好的做法：

将变量设置为易于理解的
声明所有变量
在模块顶部放置Option Explicit，因此需要变量声明
缩进您的代码

编辑：添加了与原始资料相同的工作表顺序，并删除了多余的工作表

代码：

Option Explicit

Public Sub ConvertFormulasToValuesAllWorksheets()

    Dim newBook As Workbook
    Dim sourceSheet As Worksheet
    Dim targetSheet As Worksheet

    Dim filePath As String
    Dim fileName As String
    Dim fileFullPath As String


    On Error GoTo CleanFail

    Application.DisplayAlerts = False

    ' Build the path
    filePath = "C:\Temp\"  ' "C:\Users\myusid\Desktop\myfolder\"

    fileName = "workbook2.xlsx"

    fileFullPath = filePath & fileName

    ' Add a new workbook
    Set newBook = Workbooks.Add

    ' Save it with the path built
    newBook.SaveAs fileName:=fileFullPath ', FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False

    For Each sourceSheet In ThisWorkbook.Sheets
        ' Copy the sheet
        sourceSheet.Copy After:=Workbooks(fileName).Sheets(sourceSheet.Index)

        Set targetSheet = newBook.Worksheets(sourceSheet.Name)

        ' Copy/paste values
        targetSheet.UsedRange.Value = sourceSheet.UsedRange.Value
    Next sourceSheet

    ' Delete other sheets
    For Each targetSheet In newBook.Worksheets
        If Not WorksheetExists(targetSheet.Name, ThisWorkbook) Then
            targetSheet.Delete
        End If
    Next targetSheet


CleanExit:
    Application.DisplayAlerts = True
    Exit Sub

CleanFail:
    MsgBox Err.Description
    GoTo CleanExit

End Sub

Private Function WorksheetExists(sheetName As String, targetBook As Workbook) As Boolean
    Dim evalSheet As Worksheet

    On Error Resume Next
    Set evalSheet = targetBook.Sheets(sheetName)
    On Error GoTo 0

    WorksheetExists = Not (evalSheet Is Nothing)

End Function

让我知道它是否有效。

Answer 2

尝试

Sub ConvertFormulasToValuesAllWorksheets()
Dim ws As Worksheet, rng As Range

Dim wb1 As Workbook, wb2 As Workbook

' the workbook to copy
Set wb1 = ThisWorkbook

' Copy all sheets from wb1 to new workbook
wb1.Sheets.Copy
Set wb2 = ActiveWorkbook


With Application
    .DisplayAlerts = False
    .ScreenUpdating = False
End with

For Each ws In wb2.Sheets
   With ws
       .Cells.Copy
       .Cells(1, 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
   End With
Next ws

wb2.SaveAs Filename:= _
    "C:\Users\myusid\Desktop\myfolder\workbook2.xlsx" _
     ,FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False

With Application
    .DisplayAlerts = True
    .CutCopyMode = False
    .ScreenUpdating = True
End With

End Sub

复制工作簿并在该文件中执行宏

2 个答案: