使用VBA将工作簿从一个文档复制到另一个文档，而无需打开目标工作簿

Question

我是VBA的新手，正在尝试自动更新工作簿。我有一个源工作簿A和一个目标工作簿B。两者都有一个名为roll out summary的工作表。我希望用户在A中更新此工作表，然后单击更新按钮，该按钮应运行我的宏。此宏应自动更新工作簿B中的工作表而无需打开工作簿B。

我尝试了这段代码，但它不起作用并给出错误：

Dim wkb1 As Workbook
Dim sht1 As Range
Dim wkb2 As Workbook
Dim sht2 As Range

Set wkb1 = ActiveWorkbook
Set wkb2 = Workbooks.Open("B.xlsx")
Set sht1 = wkb1.Worksheets("Roll Out Summary") <Getting error here>
Set sht2 = wkb2.Sheets("Roll Out Summary")

sht1.Cells.Select
Selection.Copy
Windows("B.xlsx").Activate
sht2.Cells.Select
Selection.PasteSpecial Paste:=xlPasteFormulasAndNumberFormats, Operation:= _
    xlNone, SkipBlanks:=False, Transpose:=False

- mou

---

你遇到了什么错误？ - Drenmi

Answer 1

sht1和sht2应该被声明为Worksheet。如果想要在不打开工作簿的情况下更新它，可以实现，但需要采用不同的方法。为了使其看起来像是没有打开工作簿，您可以打开/关闭ScreenUpdating。

请尝试以下操作：

Dim wkb1 As Workbook
Dim sht1 As Worksheet
Dim wkb2 As Workbook
Dim sht2 As Worksheet

Application.ScreenUpdating = False

Set wkb1 = ThisWorkbook
Set wkb2 = Workbooks.Open("B.xlsx")
Set sht1 = wkb1.Sheets("Roll Out Summary")
Set sht2 = wkb2.Sheets("Roll Out Summary")

sht1.Cells.Copy
sht2.Range("A1").PasteSpecial xlPasteValues
Application.CutCopyMode = False
wkb2.Close True

Application.ScreenUpdating = True

- L42

---

@mou Np. Glad it did. Btw, please see accepting answers as one way of saying Thank you in SO. It was also clearly discussed here.请注意，在SO网站上，“接受答案”是表示“谢谢”的一种方式。这在这里已经明确讨论过了。顺便说一下，很高兴它有帮助到你。 - L42

Answer 2

使用此方法 - 这对我起作用了。

Sub GetData()
Dim lRow As Long
Dim lCol As Long
 lRow = ThisWorkbook.Sheets("Master").Cells()(Rows.Count, 1).End(xlUp).Row
 lCol = ThisWorkbook.Sheets("Master").Cells()(1, Columns.Count).End(xlToLeft).Column
 If Sheets("Master").Cells(2, 1) <> "" Then

 ThisWorkbook.Sheets("Master").Range("A2:X" & lRow).Clear
 'Range(Cells(2, 1), Cells(lRow, lCol)).Select
 'Selection.Clear
 MsgBox "Creating Updated Master Data", vbSystemModal, "Information"
 End If
 'MsgBox ("No data Found")
 'End Sub

cell_value = Sheets("Monthly Summary").Cells(1, 4)
If cell_value = "" Then
Filename = InputBox("No Such File Found,Enter File Path Manually", "Bad Request")
Else
MsgBox (cell_value)
Path = "D:\" & cell_value & "\"
Filename = Dir(Path & "*.xlsx")
If Filename = "" Then

Filename = InputBox("No Such File Found,Enter File Path Manually", "Bad Request")
Else
  Do While Filename <> ""

  On Error GoTo ErrHandler
    Application.ScreenUpdating = False

  Workbooks.Open Filename:=Path & Filename, ReadOnly:=True
     ActiveWorkbook.Sheets("CCA Download").Activate
     LastRow = ActiveSheet.Cells(Rows.Count, "D").End(xlUp).Row

Range("A2:X" & LastRow).Select

Selection.Copy

ThisWorkbook.Sheets("Master").Activate

LastRow = ActiveSheet.Cells(Rows.Count, "D").End(xlUp).Select

'Required after first paste to shift active cell down one
Do While Not IsEmpty(ActiveCell)
ActiveCell.Offset(1, 0).Select
Loop

ActiveCell.Offset(0, -3).Select
Selection.PasteSpecial xlPasteValues

     Workbooks(Filename).Close
     Filename = Dir()
  Loop
  End If
  End If
  Sheets("Monthly Summary").Activate
  'Sheets("Monthly Summary").RefreshAll
  Dim pvtTbl As PivotTable
For Each pvtTbl In ActiveSheet.PivotTables
pvtTbl.RefreshTable
Next
  'Sheets("Monthly Sumaary").Refresh
  MsgBox "Monthly MIS Created Sucessfully", vbOKCancel + vbDefaultButton1, "Sucessful"
ErrHandler:
    Application.EnableEvents = True
    Application.ScreenUpdating = True
  End Sub

- dheeraj raj