有什么方法可以通过仅粘贴值但保留表格来将完整的 sheet 复制到另一个工作簿？

Question

我要保持简单：

是否可以通过仅粘贴值但保留表格的方式将完整的 sheet 复制到另一个工作簿？

现在我正在使用下面的代码，但我似乎无法将我的表保留在创建的新文件中。

关于如何解决这个问题有什么想法吗？

Sub export()

Dim SourceBook As Workbook, DestBook As Workbook, SourceSheet As Worksheet, DestSheet As Worksheet, ws As Worksheet
Dim SavePath As String, i As Integer

Set SourceBook = ThisWorkbook

SavePath = Sheets("UPDATE").Range("F23").Text

Set DestBook = Workbooks.Add

i = 1
For Each SourceSheet In SourceBook.Worksheets
    
    If i <> 1 Then
        
        SourceSheet.Cells.Copy
        
        If i > 2 Then DestBook.Worksheets.Add After:=DestBook.Sheets(DestBook.Sheets.Count)
        If UCase(SourceSheet.Name) = "DASHBOARD" Then
            Range("A1").Select
            ActiveSheet.Paste
        Else
            With Range("A1")
                .PasteSpecial xlPasteValues
                .PasteSpecial xlPasteFormats 'Delete if you don't want formats copied
            End With
        End If

        ActiveSheet.Name = SourceSheet.Name
        DestBook.Activate
        With ActiveWindow
            .DisplayGridlines = False
            '.DisplayWorkbookTabs = False
        End With
        
    End If
    
    i = i + 1
    
Next SourceSheet

SourceBook.Activate
Application.DisplayAlerts = False 'Delete if you want overwrite warning
DestBook.SaveAs Filename:=Replace(SavePath & "\" & Sheets("UPDATE").Range("F22").Text & ".xlsx", "\", "\")
Application.DisplayAlerts = True 'Delete if you delete other line

SavePath = DestBook.FullName
DestBook.Close 'Delete if you want to leave copy open
MsgBox ("A copy has been saved to " & SavePath)

End Sub

Answer 1

也许只是以编程方式重新创建 table，例如：

With ActiveSheet
    Dim table As ListObject
    Set table = .ListObjects.Add(xlSrcRange, .UsedRange)
End With

Answer 2

导出工作簿（表作为值）

第一个工作表将被跳过，而 Dashboard 工作表将按原样复制。其余部分将与包含值而不是公式的表一起复制。

Option Explicit

Sub ExportWorkbook()

    Dim SourceBook As Workbook, DestBook As Workbook
    Dim SourceSheet As Worksheet ', DestSheet As Worksheet
    Dim tbl As ListObject
    Dim FolderPath As String, FileName As String, SavePath As String
    Dim i As Long
    
    Set SourceBook = ThisWorkbook
    
    ' If the first worksheet is named "UPDATE" then use ...Worksheets(1)
    ' to remove confusion (consistency issue).
    With SourceBook.Worksheets("UPDATE")
        FolderPath = .Range("F23").Value
        FileName = .Range("F22").Value & ".xlsx"
    End With
    SavePath = Replace(FolderPath & "\" & FileName, "\", "\")
    
    Application.ScreenUpdating = False
    
    ' If a workbook with the same name as the name of the Destination Workbook
    ' is already open, close it.
    On Error Resume Next
    Set DestBook = Workbooks(FileName)
    On Error GoTo 0
    If Not DestBook Is Nothing Then
        DestBook.Close SaveChanges:=True
    End If
   
    i = 1
    
    For Each SourceSheet In SourceBook.Worksheets
        
        If i > 1 Then ' Skip first worksheet.
            
            If i = 2 Then ' Create Destination Workbook from 2nd worksheet.
                SourceSheet.Copy ' creates new workbook containing one worksheet
                Set DestBook = ActiveWorkbook
            Else ' Copy worksheet to Destination Workbook.
                SourceSheet.Copy After:=DestBook.Sheets(DestBook.Sheets.Count)
            End If
            ' Note that the current destination worksheet becomes active.
            ' (You could do 'Set DestSheet = ActiveSheet'.)
            
            If StrComp(SourceSheet.Name, "DASHBOARD", vbTextCompare) <> 0 Then
                For Each tbl In ActiveSheet.ListObjects
                    tbl.DataBodyRange.Value = tbl.DataBodyRange.Value
                Next tbl
            End If
            
            With ActiveWindow
                .DisplayGridlines = False
                '.DisplayWorkbookTabs = False
            End With
        
        End If
        
        i = i + 1
        
    Next SourceSheet
    
    Application.DisplayAlerts = False 'Delete if you want overwrite warning
    DestBook.SaveAs FileName:=SavePath
    Application.DisplayAlerts = True 'Delete if you delete other line
    
    DestBook.Worksheets(1).Activate
    DestBook.Saved = True ' Just for easy closing while testing (out-comment)
    'DestBook.Close 'Out-comment if you want to leave copy open
    
    Application.ScreenUpdating = True
    
    MsgBox "A copy has been saved to " & SavePath, vbInformation, "Export"

End Sub

有什么方法可以通过仅粘贴值但保留表格来将完整的 sheet 复制到另一个工作簿？

Is there any way to copy a complete sheet to another workbook by pasting only the values, but keeping the tables?

datatable

excel

vba

copy

spreadsheet

导出工作簿（表作为值）