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

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. 复制＆gt;＆gt;粘贴为值

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