具有很高难度的VBA(不同工作簿之间的数据提取)

wangzhongtu

要求1:
      将左边表格里的数据提取到工作簿2的工作表中的相应位置,效果见工作簿2中绿色区域
要求2:
      将工作簿1中表格里的数据提取到工作簿2的工作表中的相应位置,效果见工作簿2中绿色区域
要求3:
      以上两种做法要求通过VBA代码,并点击图片来自动实现
说明:
     左边的表格数据与表1的格式数据完全一致
请高手进来帮帮忙!!!!!

topluhw

问题的要点是不同工作簿对象的引用
下面以<将工作簿1中表格里的数据提取到工作簿2的工作表中的相应位置>为例解决

1)在<VBA工作簿.xls>中,右击相关图形
2)在弹出菜单中点取[指定宏]
3)在显现的对话框中点取[新建]
4)在显现的VBA编辑器中,出现如下进程定义语句
  Sub 矩形2_单击()
  End Sub
5)将下列语句写入进程体
    Workbooks("工作簿1.xls").Sheets("表1-1").Range("A3:G3").Copy _
    Workbooks("工作簿2.xls").Sheets("表2-1").Cells(26, 1)
6)打开相关工作簿(手动方式或代码方式都可以)
7)点击相关图片即可实现要求

zhaogang1960

请测试：
不同工作簿之间的数据提取.rar (20.2 KB, 下载次数: 1328)

2009-10-10 10:30 上传

点击文件名下载附件

wangzhongtu

呵呵原来是赵刚大侠帮忙解决问题呀    太好了 我刚才测试了下 基本上是符合本人的要求的  
不过我这个程序执行后会同时提取数据2次  我要的是1次   
而且 “名称、规格、摘要、数量、单价、金额”这些是工作簿2中本来就在固定位置设好的   只要提取具体的项目内容在相应的单元格里即可  
还有一点希望赵刚老师帮忙帮到底（尽量在比较关键的代码后面表上标上注释，以方便初学这容易理解、学习......

praijna

“呵呵原来是赵刚大侠帮忙解决问题呀    太好了 我刚才测试了下 基本上是符合本人的要求的”，我怎么感谢楼主的口吻不是在求助，而是在挑战呢？

zhaogang1960

请测试：
Sub Macro1()
    Dim arr, brr(1 To 3), crr(1 To 3)
    arr = Range("B3:G3")
    brr(1) = arr(1, 1)
    brr(1 + 1) = arr(1, 2)
    brr(1 + 2) = arr(1, 6)
    crr(1) = arr(1, 3)
    crr(1 + 1) = arr(1, 4)
    crr(1 + 2) = arr(1, 5)
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    With Workbooks.Open(ThisWorkbook.Path & "\工作簿2.xls")
        With .Sheets("表2-1")
            .Cells(2, 3).Resize(3) = WorksheetFunction.Transpose(brr)
            .Cells(2, 6).Resize(3) = WorksheetFunction.Transpose(crr)
        End With
        .Close True
    End With
    Application.ScreenUpdating = True
    MsgBox "完毕"
End Sub
Sub Macro2()
    Dim arr, brr(1 To 3), crr(1 To 3)
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    With GetObject(ThisWorkbook.Path & "\工作簿1.xls")
        With .Sheets("表1-1")
            arr = .Range("B3:G3")
            brr(1) = arr(1, 1)
            brr(1 + 1) = arr(1, 2)
            brr(1 + 2) = arr(1, 6)
            crr(1) = arr(1, 3)
            crr(1 + 1) = arr(1, 4)
            crr(1 + 2) = arr(1, 5)
        End With
        .Close False
    End With
    With Workbooks.Open(ThisWorkbook.Path & "\工作簿2.xls")
        With .Sheets("表2-1")
            .Cells(2, 3).Resize(3) = WorksheetFunction.Transpose(brr)
            .Cells(2, 6).Resize(3) = WorksheetFunction.Transpose(crr)
        End With
        .Close True
    End With
    Application.ScreenUpdating = True
    MsgBox "完毕"
End Sub

wangzhongtu

原来要达到真正的效果这么麻烦呀   要这么多的代码   下载了  有空好好学习学习
   辛苦 zhaogang1960  大侠了   !!!!!!!!!

gogowind

学习了。

tclnxc

学习一下！！

迅岐同心

学习了，谢谢版主！