跨文件批量取数

zijihejiu

http://www.excelpx.com/thread-335111-1-1.html
上面是我之前的需求，跨文件批量取数。代码如下：

Sub Macro1()    '指定到按钮
On Error Resume Next    '屏蔽所有错误提示
Dim arr, brr, crr, d, wb As Workbook, i&, j&, zf$  '创建变量arr, brr, crr, d, wb（%：整数型变量(Integer)，&：长整型变量（Long)，$：字符串变量（String））
Application.ScreenUpdating = False  '屏蔽刷屏
Set d = CreateObject("scripting.dictionary")    '给对象变量“d”赋值--创建字典
arr = Sheets(3).UsedRange     '工作表3使用区域
ReDim brr(1 To UBound(arr) - 1, 1 To UBound(arr, 2) - 1)    'ReDim给brr分配元素，UBound取最大值（确定数组的指定维的最大可用下标）
Set wb = GetObject(ThisWorkbook.Path & "\源文件.xls")       '将“源文件”的路径赋值给对象变相“wb”
crr = wb.Sheets(3).UsedRange        'UsedRange：选中已使用的单元格区域
wb.Close 0          '关闭指定的窗口
For i = 2 To UBound(crr)    '循环2～数组crr之间第一组的最大数，标赋值给i
    For j = 2 To UBound(crr, 2)     '循环2～数组crr之间第二组最大数，赋值给j
        zf = crr(i, 1) & "," & crr(1, j)    '
        d(zf) = crr(i, j)
    Next
Next
For i = 2 To UBound(arr)
    For j = 2 To UBound(arr, 2)
        zf = arr(1, j) & "," & arr(i, 1)
        brr(i - 1, j - 1) = d(zf)
    Next
Next
Range("b3").Resize(UBound(brr), UBound(brr, 2)) = brr
Application.ScreenUpdating = True
End Sub

担当调整了"源文件.xls"和"销售表.xls"文件中在表格中的位置之后（如下图），我尝试调整代码，但一直有问题。不知道怎么解决。麻烦高手们帮我看看，万分感谢！
打包文件： Downloads-11.28.rar (25.78 KB, 下载次数: 20)

2014-11-28 14:21 上传

点击文件名下载附件

qh8600

其实这个转置就可以了，复制 选择性黏贴  转置
非要用VBA，录制宏，把区域改成不固定的可以了

zijihejiu

qh8600 发表于 2014-11-28 18:01
其实这个转置就可以了，复制 选择性黏贴 转置

实际情况很复杂，源文件数量也很多，附件中的例子只能代表问题的缩影，不是真实文件哈。。

qh8600

zijihejiu 发表于 2014-11-28 18:06
实际情况很复杂，源文件数量也很多，附件中的例子只能代表问题的缩影，不是真实文件哈。。

有问题不会一下子说清楚哈

爱疯

1楼附件打开时不知道有木有危险（建议看看是否重传下）
1楼链接里的附件，打开时没这提示

zijihejiu

爱疯 发表于 2014-11-28 18:39
1楼附件打开时不知道有木有危险（建议看看是否重传下）
1楼链接里的附件，打开时没这提示

是因为里面有宏啊，不可能是病毒哦

zijihejiu

qh8600 发表于 2014-11-28 18:08
有问题不会一下子说清楚哈

主要原因是我没有弄明白代码的原理，天天都有数据源文件需要取数，全打包进来真也不太现实，请指点下代码问题哈，万分感谢啦

zijihejiu

qh8600 发表于 2014-11-28 18:08
有问题不会一下子说清楚哈

主要原因是我没有弄明白代码的原理，天天都有数据源文件需要取数，全发进来也不现实，请指点下代码问题哈，万分感谢。。。

zijihejiu

谁能帮下啊，谢谢啦

QLZ0602

可qq 联系 695982239