从另一个工作簿复制工作表，包括图表

Question

我想从另一个工作簿复制工作表并替换ThisWorkbook中的工作表。但是，我不想删除ThisWorkbook中的工作表，因为我在其他工作表上有公式引用此特定工作表。通过首先删除工作表，我的公式将最终为#REF。

因此，我编写了以下代码，但此代码不复制图表：

Sub Copy_from_another_workbook

    Dim wb As Workbook
    Dim sWorksheet As String

    ThisWorkbook.Worksheets("Destinationsheet").Cells.ClearContents
    Set wb = Workbooks.Open(ThisWorkbook.Worksheets("input").Range("sFileSource"), ReadOnly:=True, UpdateLinks:=False)
    sWorksheet = ThisWorkbook.Worksheets("input").Range("sWorksheetSource")

    wb.Worksheets(sWorksheet).Cells.Copy
    ThisWorkbook.Worksheets("Destinationsheet").Activate
    ThisWorkbook.Worksheets("Destinationsheet").Range("A1").Select
    Selection.PasteSpecial xlPasteValues, operation:=xlNone, skipblanks:=False, Transpose:=False
    Selection.PasteSpecial xlPasteColumnWidths
    Selection.PasteSpecial xlPasteFormats
    Selection.UnMerge

    wb.Close

End Sub

此代码没有错误但不复制图表。我还没有找到一种方法来复制带有pastespecial的图表，我从this post了解到，当选择范围时，你不能使用Paste方法。

如何粘贴数据，包括图表，仍然可以使用pastespecial，因为我不想粘贴公式？

或者是否有其他方法可以达到要求的结果？

Answer 1

您无需激活或选择任何内容。这是您自己的代码评论版本，修改后不做这个并部分重新排列。

Sub Copy_from_another_workbook()

    Dim WbTgt As Workbook               ' Target
    Dim WbSrc As Workbook               ' Source
    Dim Wname As String                 ' intermediate use for both Wb and Ws:
                                        ' better let a "Sheet" be a sheet
'    Dim rCell As Range

    Application.ScreenUpdating = False
    Set WbTgt = ThisWorkbook
    With WbTgt.Worksheets("input")
        ' extracting the name separately makes testing the code easier
        Wname = .Range("sFileSource")
        Set WbSrc = Workbooks.Open(Wname, ReadOnly:=True, UpdateLinks:=False)
        Wname = .Range("sWorksheetSource")
    End With

    With WbSrc
        .Worksheets(Wname).Copy Before:=WbTgt.Worksheets("Destinationsheet")
        .Close
    End With

'    ThisWorkbook.Activate
'    For Each rCell In ThisWorkbook.Worksheets("SheetWithFormulas").Range("b1:c30")
'        rCell.Formula = Replace(rCell.Formula, "Destinationsheet", "'" & Wname & "'")
'    Next
    ' Consider a less specific range instead:-
    ' With WbTgt.Worksheets("SheetWithFormulas").UsedRange
    With WbTgt.Worksheets("SheetWithFormulas").Range("B1:C30")
        .Replace What:="Destinationsheet", Replacement:="'" & Wname & "'", _
         LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
    End With

    With WbTgt.Worksheets(Wname).Cells
        .Copy
        .PasteSpecial xlPasteValues     ', Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        WbTgt.Worksheets("Destinationsheet").Delete
        .Name = "Destinationsheet"
    End With
    Application.ScreenUpdating = True
End Sub

我无法测试运行代码。

Answer 2

将代码更改为：

Sub Copy_from_another_workbook

    Dim wb As Workbook
    Dim sWorksheet As String
    Dim rCell As Range

    Set wb = Workbooks.Open(ThisWorkbook.Worksheets("input").Range("sFileSource"), ReadOnly:=True, UpdateLinks:=False)
    sWorksheet = ThisWorkbook.Worksheets("input").Range("sWorksheetSource")
    wb.Worksheets(sWorksheet).Copy before:=ThisWorkbook.Worksheets("Destinationsheet")

    ThisWorkbook.Activate

    For Each rCell In ThisWorkbook.Worksheets("SheetWithFormulas").Range("b1:c30")
        rCell.Formula = Replace(rCell.Formula, "Destinationsheet", "'" & sWorksheet & "'")
    Next

    ThisWorkbook.Worksheets(sWorksheet).Cells.Select
    Selection.Copy
    Selection.PasteSpecial xlPasteValues, operation:=xlNone, skipblanks:=False, Transpose:=False
    wb.Close

    ThisWorkbook.Worksheets("Destinationsheet").Delete
    ThisWorkbook.Worksheets(sWorksheet).Name = "Destinationsheet"

End sub