如何用VBA实现跨工作簿的复制粘贴?高手给看看代码
答案:3 悬赏:0
解决时间 2021-01-08 07:50
- 提问者网友:焚苦与心
- 2021-01-07 08:49
如何用VBA实现跨工作簿的复制粘贴?高手给看看代码
最佳答案
- 二级知识专家网友:迟山
- 2021-01-07 10:07
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复制,所以我的区域是多个,这样一来,也运行不了,不知为何?
这一句应在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复制,所以我的区域是多个,这样一来,也运行不了,不知为何?
全部回答
- 1楼网友:洎扰庸人
- 2021-01-07 12:05
第一句是出现错误继续
第二句是禁止屏幕刷新
第三局是恢复屏幕刷新
后两句都是为了加快运行速度
第二句是禁止屏幕刷新
第三局是恢复屏幕刷新
后两句都是为了加快运行速度
- 2楼网友:煞尾
- 2021-01-07 10:36
要想不出现提示.改成这样:
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
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
我要举报
如以上问答内容为低俗、色情、不良、暴力、侵权、涉及违法等信息,可以点下面链接进行举报!
大家都在看
推荐资讯