Question

如何用VBA实现跨工作簿的复制粘贴？高手给看看代码

代码如下：应该有BUG，请帮助指正

Sub 按钮1_单击()

On Error Resume Next
Dim i, tt, ss, n
Application.ScreenUpdating = False

n = 1

For i = 1 To 2

Set ss = Workbooks.Open(ThisWorkbook.Path & "\" & i & ".xls")
Set tt = Workbooks.Open(ThisWorkbook.Path & "\" & "汇总" & ".xls")

ss.Worksheets("RNC2166 KPI").Range("F4:F170").Copy tt.Worksheets(CStr(1)).Range(1, n) '此处为 表，或者 SHEET1,或者其他的值
n = n + 1
ss.Close

Next i

Application.ScreenUpdating = True

End Sub
请先给我指正代码的错误，好像运行不了~~

代码是找的，请给解释下，这个3句我看不太懂

On Error Resume Next

Application.ScreenUpdating = False

Application.ScreenUpdating = True

Answer 1

Set tt = Workbooks.Open(ThisWorkbook.Path & "\" & "汇总" & ".xls")
这一句应在FOR的外面，否则两次打开汇总表。

tt.Worksheets(CStr(1)).Range(1, n)
叫“1”的表即CStr(1)不知你有没，Range(1, n) ，这表述错了，应为Cells(1,n)。

我修正一下的代码，你在一个同文件夹下建3个文件，1.xls，2.xls，3.xls。表3是汇总表。再建一个BOOK1表，也存在该文件夹，在此表放入下面代码，执行则可。
Sub 按钮1_单击()

On Error Resume Next
Dim i, tt, ss, n
Application.ScreenUpdating = False
n = 1
Set tt = Workbooks.Open(ThisWorkbook.Path & "\" & "3" & ".xls")
For i = 1 To 2
Set ss = Workbooks.Open(ThisWorkbook.Path & "\" & i & ".xls")
ss.Worksheets("Sheet1").Range("F4:F170").Copy tt.Worksheets("Sheet1").Cells(1, n)
n = n + 1
ss.Close
Next i
Application.ScreenUpdating = True

End Sub

追问

由于我那个表格里面带函数，如何实现 选择性粘贴----数值？ 用代码实现

而且，没次循环中，SS.close，之后，还会提示，是否要保存？如何避免呢

追答

ss.Worksheets("Sheet1").Range("F4:F170").Copy tt.Worksheets("Sheet1").Cells(1, n)
改为：
ss.Worksheets("Sheet1").Range("F4:F170").Copy
tt.Worksheets("Sheet1").Cells(1, n).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

下面这句相应替换
ss.Close SaveChanges:=False
只是有个小问题，复制的剪贴板会提示清除。

全部代码：貌似可以解决不出现提示
Sub 按钮1_单击()
On Error Resume Next
Dim i, tt, ss, n
Application.ScreenUpdating = False
n = 1
Set tt = Workbooks.Open(ThisWorkbook.Path & "\" & "3" & ".xls")
For i = 1 To 2
Set ss = Workbooks.Open(ThisWorkbook.Path & "\" & i & ".xls")
ss.Worksheets("Sheet1").Range("F4:F170").Copy
tt.Worksheets("Sheet1").Cells(1, n).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
n = n + 1
Application.CutCopyMode = False
ss.Close SaveChanges:=False
Next i
Application.ScreenUpdating = True
End Sub

追问

ss.Worksheets("RNC2166 KPI").Range("F4:F26,F30:F36,F44,F52,F58,F66,F74:F89,F92:F170").Copy

tt.Worksheets("Sheet1").Cells(4, n + 2).Select

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

n = n + 1
我的复制是跨 RANGE复制，所以我的区域是多个，这样一来，也运行不了，不知为何？

Answer 2

要想不出现提示.改成这样:
Sub 按钮1_单击()
On Error Resume Next
Dim i, tt, ss, n
Application.DisplayAlerts = True '禁止提示.
Application.ScreenUpdating = False
n = 1
Set tt = Workbooks.Open(ThisWorkbook.Path & "\" & "3" & ".xls")
For i = 1 To 2
Set ss = Workbooks.Open(ThisWorkbook.Path & "\" & i & ".xls")
ss.Worksheets("Sheet1").Range("F4:F170").Copy
tt.Worksheets("Sheet1").Cells(1, n).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
n = n + 1
Application.CutCopyMode = False
ss.Close SaveChanges:=False
Next i
tt.close
set tt =nothing
Application.ScreenUpdating = True
Application.DisplayAlerts = false '恢复提示
End Sub

Answer 3

第一句是出现错误继续
第二句是禁止屏幕刷新
第三局是恢复屏幕刷新
后两句都是为了加快运行速度