[已解决]跨工作薄导入数据

salt

请老师帮忙修改一下代码，导入汇总表里的数据从E3到J386，现在的代码只能导入单列数据，此代码也是从论坛里搜的，谢谢

最佳答案

月排行榜 / 总排行榜

dsmch

2014-12-23 20:28

Sub Macro2()
On Error Resume Next
Dim arr, brr, crr, d, wb As Workbook, i&, j%
Set d = CreateObject("scripting.dictionary")
arr = Range("a1").CurrentRegion
ReDim brr(1 To UBound(arr) - 2, 1 To 5)
Application.ScreenUpdating = False
wj = Application.GetOpenFilename
If wj <> False Then Set wb = GetObject(wj)
crr = wb.Sheets(1).Range("a1").CurrentRegion
wb.Close 0
For i = 4 To UBound(crr)
    z = crr(i, 2) & "," & crr(i, 3) & "," & crr(i, 4)
    For j = 5 To 9
        zf = z & "," & crr(3, j)
        d(zf) = d(zf) + crr(i, j)
    Next
Next
For i = 3 To UBound(arr)
    z = arr(i, 2) & "," & arr(i, 3) & "," & arr(i, 4)
    For j = 5 To 9
        zf = z & "," & arr(2, j)
        brr(i - 2, j - 4) = d(zf)
    Next
Next
Range("e3").Resize(UBound(brr), 5) = brr
Application.ScreenUpdating = True
End Sub

跳转到最佳答案楼层

dsmch

两表标题必须对应，建议重新模拟附件

salt

dsmch 发表于 2014-12-23 16:45
两表标题必须对应，建议重新模拟附件

老师标题修改了，你看是这样的吗？

dsmch

1. Sub Macro2()
   
2. Dim arr, brr, crr, d, wb As Workbook, i&, j%
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = Range("a1").CurrentRegion
   
5. ReDim brr(1 To UBound(arr) - 2, 1 To 5)
   
6. Application.ScreenUpdating = False
   
7. Set wb = GetObject(ThisWorkbook.Path & "\汇总表.xls")
   
8. crr = wb.Sheets(1).Range("a1").CurrentRegion
   
9. wb.Close 0
   
10. For i = 4 To UBound(crr)
    
11.     z = crr(i, 2) & "," & crr(i, 3) & "," & crr(i, 4)
    
12.     For j = 5 To 9
    
13.         zf = z & "," & crr(3, j)
    
14.         d(zf) = d(zf) + crr(i, j)
    
15.     Next
    
16. Next
    
17. For i = 3 To UBound(arr)
    
18.     z = arr(i, 2) & "," & arr(i, 3) & "," & arr(i, 4)
    
19.     For j = 5 To 9
    
20.         zf = z & "," & arr(2, j)
    
21.         brr(i - 2, j - 4) = d(zf)
    
22.     Next
    
23. Next
    
24. Range("e3").Resize(UBound(brr), 5) = brr
    
25. Application.ScreenUpdating = True
    
26. End Sub

复制代码

salt

dsmch 发表于 2014-12-23 17:16

老师，能否在不同的文件夹里选择汇总表导入。谢谢

dsmch

Sub Macro2()
On Error Resume Next
Dim arr, brr, crr, d, wb As Workbook, i&, j%
Set d = CreateObject("scripting.dictionary")
arr = Range("a1").CurrentRegion
ReDim brr(1 To UBound(arr) - 2, 1 To 5)
Application.ScreenUpdating = False
wj = Application.GetOpenFilename
If wj <> False Then Set wb = GetObject(wj)
crr = wb.Sheets(1).Range("a1").CurrentRegion
wb.Close 0
For i = 4 To UBound(crr)
    z = crr(i, 2) & "," & crr(i, 3) & "," & crr(i, 4)
    For j = 5 To 9
        zf = z & "," & crr(3, j)
        d(zf) = d(zf) + crr(i, j)
    Next
Next
For i = 3 To UBound(arr)
    z = arr(i, 2) & "," & arr(i, 3) & "," & arr(i, 4)
    For j = 5 To 9
        zf = z & "," & arr(2, j)
        brr(i - 2, j - 4) = d(zf)
    Next
Next
Range("e3").Resize(UBound(brr), 5) = brr
Application.ScreenUpdating = True
End Sub

salt

dsmch 发表于 2014-12-23 20:28
Sub Macro2()
On Error Resume Next
Dim arr, brr, crr, d, wb As Workbook, i&, j%

dsmch老师，请看附件，麻烦dsmch老师看看能否实现不，谢谢dsmch老师。同时提取文件夹里工作薄和仓库出库结算汇总表里的数据，自动在合计后面填充出库数量、单价，然后用出库数量减去合计后的值乘单价，填写金额。