vba - 复制整个工作表并粘贴为值

Question

我正在尝试将活动工作表复制到新工作簿中，然后保存该新工作簿并将其关闭。这是通过单击活动工作表中的表单（按钮）触发的。然后在保存之前在新工作簿中删除该按钮。

我在活动工作表中使用公式。我试图只复制值和任何其他格式。

新工作簿不显示值，而是只显示空单元格（也没有显示公式，这当然可以）。具体来说，使用间接公式复制单元格时似乎会出现问题；对于使用对原始工作簿中其他工作表的更简单引用的单元格来说，这似乎没有问题。

这是代码：

Sub CopyRemoveFormAndSave()
    Dim RelativePath As String
    Dim shp As Shape
    Dim testStr As String

    ' Copy and Paste Active Sheet
    ActiveSheet.Copy
    With ActiveSheet.UsedRange
        .Value = .Value
    End With

    ' Remove forms
    For Each shp In ActiveSheet.Shapes
        If shp.Type = 8 Then
            If shp.FormControlType = 0 Then
                testStr = ""
                On Error Resume Next
                testStr = shp.TopLeftCell.Address
                On Error GoTo 0
                If testStr <> "" Then shp.Delete
            Else
                shp.Delete
            End If
        End If
    Next shp

    ' Save New Workbook and Close
    Application.DisplayAlerts = False
    RelativePath = ThisWorkbook.Path & "\" & ActiveSheet.Name & "_Reporting_" & Format(Now, "yymmdd") & ".xlsx"
    ActiveWorkbook.SaveAs Filename:=RelativePath
    ActiveWorkbook.Close
    Application.DisplayAlerts = True

End Sub

Answer 1

这是一种略有不同的方法。

逻辑：

1. 在用户的临时目录中创建活动工作簿的副本
2. 打开副本
3. 将公式更改为值。其余的格式保持不变。
4. 删除所有不必要的工作表
5. 删除不必要的形状。

代码：（经过试验和测试）

Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" _
(ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long

Private Const MAX_PATH As Long = 260

'~~> Function to get user's temp directoy
Function TempPath() As String
    TempPath = String$(MAX_PATH, Chr$(0))
    GetTempPath MAX_PATH, TempPath
    TempPath = Replace(TempPath, Chr$(0), "")
End Function

Sub CopyRemoveFormAndSave()
    Dim wb As Workbook, wbNew As Workbook
    Dim ws As Worksheet
    Dim wsName As String, NewName As String
    Dim shp As Shape

    Set wb = ThisWorkbook

    wsName = ActiveSheet.Name

    NewName = wsName & ".xlsm"

    wb.SaveCopyAs TempPath & NewName

    Set wbNew = Workbooks.Open(TempPath & NewName)

    wbNew.Sheets(wsName).UsedRange.Value = wbNew.Sheets(wsName).UsedRange.Value

    Application.DisplayAlerts = False
    For Each ws In wbNew.Worksheets
        If ws.Name <> wsName Then ws.Delete
    Next ws
    Application.DisplayAlerts = True

    For Each shp In wbNew.Sheets(wsName).Shapes
        If shp.Type = 8 Then shp.Delete
    Next

    '
    '~~> Do a save as for the new workbook if required.
    '
End Sub

Answer 2

作为您的答案，这可能有点晚，但将来可能会对其他人有所帮助。

脚步：

1. 转到工作簿中的第一张工作表
2. 按住Shift按钮并单击工作簿中的最后一张工作表（选中所有工作表）
3. 通过Ctrl+ A+选择活动工作表中的所有单元格A，或者单击 A 列和第 1 行左上角的小箭头。（活动工作表中的所有单元格都被选中）
4. 复制 >> 粘贴为值

此副本粘贴为所有工作表中所有单元格的值。将文件另存为。