如何跨工作簿取数？

zhaogang1960

请看附件
单位支出明表.rar (92.97 KB, 下载次数: 51)

2012-1-26 15:56 上传

点击文件名下载附件

dtxczjzmp

zhaogang1960 发表于 2012-1-26 15:56
请看附件

辛苦zhaogang1960老师了！非常的OK，就只差碰到跨列居中的问题没解决了，如源数据表1的第co~cq列，是一个单位跨列居中，只取到5012110307的单位对应数据，而5012110302的单位对应数据没取到。

zhaogang1960

dtxczjzmp 发表于 2012-1-26 16:17
辛苦zhaogang1960老师了！非常的OK，就只差碰到跨列居中的问题没解决了，如源数据表1的第co~cq列，是一个 ...

我以为一行中只能有一个数据，查到后就退出循环了，修改如下：
单位支出明表.rar (98.42 KB, 下载次数: 126)

2012-1-26 16:31 上传

点击文件名下载附件

dtxczjzmp

zhaogang1960 发表于 2012-1-26 16:31
我以为一行中只能有一个数据，查到后就退出循环了，修改如下：

老师，您太棒了，非常的感谢您！

zhaogang1960

dtxczjzmp   2012-1-26 21:14 关于你在“如何跨工作簿取数？”的帖子
老师：您好！能否帮我取数的目标工作表再加个排序的代码？(最好按升序排列)谢谢！

短信收到：

1. Sub Macro1()
   
2.     Dim MyPath$, MyName$, arr, brr(1 To 60000, 1 To 4), i&, j&, m&
   
3.     MyPath = ThisWorkbook.Path & ""
   
4.     MyName = Dir(MyPath & "*.xls")
   
5.     Application.ScreenUpdating = False
   
6.     Do While MyName <> ""
   
7.         If MyName <> ThisWorkbook.Name Then
   
8.             With GetObject(MyPath & MyName)
   
9.                 arr = .Sheets(1).[a1].CurrentRegion
   
10.                 .Close False
    
11.             End With
    
12.             For j = 4 To UBound(arr, 2)
    
13.                 If Len(arr(6, j)) = 0 Then arr(6, j) = arr(6, j - 1)
    
14.             Next
    
15.             For i = 8 To UBound(arr)
    
16.                 If Len(arr(i, 1)) > 8 Then
    
17.                     For j = 4 To UBound(arr, 2)
    
18.                         If Len(arr(i, j)) Then
    
19.                             m = m + 1
    
20.                             brr(m, 1) = arr(i, 1)
    
21.                             brr(m, 2) = arr(i, 2)
    
22.                             brr(m, 3) = arr(6, j)
    
23.                             brr(m, 4) = arr(i, j)
    
24. '                            Exit For
    
25.                         End If
    
26.                     Next
    
27.                 End If
    
28.             Next
    
29.         End If
    
30.         MyName = Dir
    
31.     Loop
    
32.     ActiveSheet.UsedRange.Offset(4).ClearContents
    
33.     With [a5].Resize(m, 4)
    
34.         .Value = brr
    
35.         .Sort Key1:=Range("A5"), Order1:=xlAscending
    
36.     End With
    
37.     Application.ScreenUpdating = True
    
38. End Sub
    
39. 
    

复制代码

dtxczjzmp

谢谢老师热心帮助！{:soso_e163:}{:soso_e163:}{:soso_e182:}

lcmphy

学习中，谢谢各位。