我想从另一个工作簿复制工作表并替换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了解到,在选择范围时你不能使用粘贴方法。
如何粘贴包含图表的数据并且仍然可以使用pastespecial,因为我不想粘贴公式?
还是有另一种方法可以达到要求的结果吗?
答案 0 :(得分: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
我无法测试运行代码。
答案 1 :(得分:0)
将代码更改为:
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