Дублируйте рабочую книгу и выполните макрос в этом файле

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

Вот еще один подход, который дает вам некоторую гибкость, устанавливая имя файла и путь в переменных.

Также некоторые полезные практики:

1. Установите переменные на что-то понятное
2. Объявите все ваши переменные
3. Вверху ваших модулей поместите Option Explicit, поэтому требуется объявление переменной
4. Отступ в коде

---

РЕДАКТИРОВАТЬ: Добавлено сохранить тот же порядок листов, как в исходной книге и удалить дополнительные листы

Код:

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