[已解决]求助论坛老师写一段代码，跨工作簿打开文件。

yslvictor

在book1所在的文件夹中可能有book2（在同一文件夹中查找并打开book2），在book1中运行vba代码：
目的：打开book2，复制book2中sheet2的A1：C1数据，粘贴到book1的sheet1的B2：D2中。
条件：如果book2是打开状态，则直接进行复制粘贴操作；
         如果book2是关闭状态，则打开后进行复制粘贴操作；
         如果book2不存在，则提示“book2不存在”直接后退出vba(不需要选择路径查找)。
Sub 打开复制()
'在这里添加上述条件的代码
   Range("A1:C1").Select
    Selection.Copy
    Windows("Book1.xls").Activate
    Range("B2").Select
    ActiveSheet.Paste
End Sub
打开复制.rar (2.79 KB, 下载次数: 12)

2012-12-16 18:03 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2012-12-16 19:59

1. Sub 按钮1_单击()
   
2.     Dim Wbname$, wb$
   
3.     Wbname = "Book2.xls"    '工作簿名
   
4.     wb = ThisWorkbook.Path & "" & Wbname   '完整的工作簿名
   
5.     If Len(Dir(wb, vbNormal)) = 0 Then MsgBox Wbname & " 不存在": Exit Sub  '检测是否存在BOOK2工作簿
   
6.     Application.ScreenUpdating = False  '关闭屏幕刷新
   
7.     On Error Resume Next                '忽略错误
   
8.     If Workbooks(wb) Is Nothing Then    '检测BOOK2是否已经打开
   
9.         Workbooks.Open wb               '打开BOOK2
   
10.     End If
    
11.    
    
12.     With Workbooks(Wbname)
    
13.         '复制BOOK2中SHEET2的A1:C1到BOOK1的SHEET1的B2
    
14.         .Worksheets("sheet2").Range("a1:c1").Copy ThisWorkbook.Worksheets("sheet1").Range("b2")
    
15.         .Close False    '关闭（不保存）
    
16.     End With
    
17.     Application.ScreenUpdating = False  '打开屏幕刷新
    
18. End Sub

复制代码

跳转到最佳答案楼层

hwc2ycy

1. Sub 按钮1_单击()
   
2.     Dim Wbname$, wb$
   
3.     Wbname = "Book2.xls"
   
4.     wb = ThisWorkbook.Path & "" & Wbname
   
5.     If Len(Dir(wb, vbNormal)) = 0 Then MsgBox Wbname & " 不存在": Exit Sub
   
6.     Application.ScreenUpdating = False
   
7.     On Error Resume Next
   
8.     If Workbooks(wb) Is Nothing Then
   
9.         Workbooks.Open wb
   
10.     End If
    
11.     With Workbooks(Wbname)
    
12.         .Worksheets("sheet2").Range("a1:c1").Copy ThisWorkbook.Worksheets("sheet1").Range("b2")
    
13.         .Close False
    
14.     End With
    
15.     Application.ScreenUpdating = False
    
16. End Sub

复制代码

hwc2ycy

1. Sub 按钮1_单击()
   
2.     Dim Wbname$, wb$
   
3.     Wbname = "Book2.xls"    '工作簿名
   
4.     wb = ThisWorkbook.Path & "" & Wbname   '完整的工作簿名
   
5.     If Len(Dir(wb, vbNormal)) = 0 Then MsgBox Wbname & " 不存在": Exit Sub  '检测是否存在BOOK2工作簿
   
6.     Application.ScreenUpdating = False  '关闭屏幕刷新
   
7.     On Error Resume Next                '忽略错误
   
8.     If Workbooks(wb) Is Nothing Then    '检测BOOK2是否已经打开
   
9.         Workbooks.Open wb               '打开BOOK2
   
10.     End If
    
11.    
    
12.     With Workbooks(Wbname)
    
13.         '复制BOOK2中SHEET2的A1:C1到BOOK1的SHEET1的B2
    
14.         .Worksheets("sheet2").Range("a1:c1").Copy ThisWorkbook.Worksheets("sheet1").Range("b2")
    
15.         .Close False    '关闭（不保存）
    
16.     End With
    
17.     Application.ScreenUpdating = False  '打开屏幕刷新
    
18. End Sub

复制代码

梅一枝

1. Sub dd()
   
2.     Dim na
   
3.     Dim ipath As String
   
4.     Dim str As String
   
5.     Dim filename
   
6.     ipath = ThisWorkbook.Path & "/"
   
7.     filename = dir(ipath & "*.xls")
   
8.     Do
   
9.         na = na & filename
   
10.         filename = dir
    
11.     Loop Until filename = ""
    
12. 
    
13.     If InStr(na, "Book2.xls") = 0 Then
    
14.         MsgBox "book2不存在"
    
15.         Exit Sub
    
16.     Else
    
17.         Workbooks.Open ipath & "Book2.xls"
    
18.         ActiveWorkbook.Sheets("sheet2").Range("a1:c1").Copy ThisWorkbook.Sheets(1).Range("b2:d2")
    
19.     End If
    
20. 
    
21. End Sub
    

复制代码

我也练下手

yslvictor

谢谢班级管理员老师，解释的很详细，遇到问题有很多热心的论坛老师帮助解决，真是特别的高兴。哈哈！！！