如何跨工作簿取数？

dtxczjzmp

如何把源数据工作簿的源数据表第一列科目编码长度大于8如5012110101所对应的单位取数到目标目标工作簿的目标表样式中呢？如何把源工作簿的相关源数据表移到目标工作簿中进行取数；或是如何直接从源工作簿中取数呢？具体详见附件： 单位支出明表.rar (77.85 KB, 下载次数: 73) 2012-1-25 20:33 上传 点击文件名下载附件

该贴已经同步到 dtxczjzmp的微博

doitbest

1. Public Sub subtotal1()
   
2. Dim ar(), br, i%, j%, n%
   
3. For i = 1 To 3
   
4.     With Workbooks("源数据表" & i & ".xls").Sheets(1)
   
5.     br = .Range(.[a8], .[c65536].End(3))
   
6.     For j = 1 To UBound(br)
   
7.         If Len(br(j, 1)) > 8 Then
   
8.             n = n + 1
   
9.             ReDim Preserve ar(1 To 4, 1 To n)
   
10.             ar(1, n) = br(j, 1)
    
11.             ar(2, n) = br(j, 2)
    
12.             ar(3, n) = Replace(.[a3], "编制单位：", "")
    
13.             ar(4, n) = br(j, 3)
    
14.         End If
    
15.     Next
    
16.     End With
    
17. Next
    
18. Range("a5").Resize(n, 4) = Application.Transpose(ar)
    
19. End Sub

复制代码

doitbest

请参考附件

dtxczjzmp

经测试不成功！

dtxczjzmp

doitbest 发表于 2012-1-26 08:09

运行错误9，下标越界！

dtxczjzmp

doitbest 发表于 2012-1-26 08:11
请参考附件

运行错误9，下标越界！

zhaogang1960

请测试：

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 i = 8 To UBound(arr)
    
13.                 If Len(arr(i, 1)) > 8 Then
    
14.                     m = m + 1
    
15.                     brr(m, 1) = arr(i, 1)
    
16.                     brr(m, 2) = arr(i, 2)
    
17.                     For j = 4 To UBound(arr, 2)
    
18.                         If Len(arr(i, j)) Then
    
19.                             brr(m, 3) = "局" & j - 3
    
20.                             brr(m, 4) = arr(i, j)
    
21.                             Exit For
    
22.                         End If
    
23.                     Next
    
24.                 End If
    
25.             Next
    
26.         End If
    
27.         MyName = Dir
    
28.     Loop
    
29.     ActiveSheet.UsedRange.Offset(4).ClearContents
    
30.     [a5].Resize(m, 4) = brr
    
31.     Application.ScreenUpdating = True
    
32. End Sub
    

复制代码

zhaogang1960

修改一下，不要第一列科目编码长度大于8，但是金额为空的：

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 i = 8 To UBound(arr)
    
13.                 If Len(arr(i, 1)) > 8 Then
    
14.                     For j = 4 To UBound(arr, 2)
    
15.                         If Len(arr(i, j)) Then
    
16.                             m = m + 1
    
17.                             brr(m, 1) = arr(i, 1)
    
18.                             brr(m, 2) = arr(i, 2)
    
19.                             brr(m, 3) = "局" & j - 3
    
20.                             brr(m, 4) = arr(i, j)
    
21.                             Exit For
    
22.                         End If
    
23.                     Next
    
24.                 End If
    
25.             Next
    
26.         End If
    
27.         MyName = Dir
    
28.     Loop
    
29.     ActiveSheet.UsedRange.Offset(4).ClearContents
    
30.     [a5].Resize(m, 4) = brr
    
31.     Application.ScreenUpdating = True
    
32. End Sub
    
33. 
    

复制代码

dtxczjzmp

zhaogang1960 发表于 2012-1-26 14:04
修改一下，不要第一列科目编码长度大于8，但是金额为空的：

感谢zhaogang1960老师的关心和帮助！但还有一个小问题那就是brr(m, 3) = "局" & j - 3这一句我不怎么理解，假如取的单位不含局的就取不进来，老师您能否再辛苦一下，那就是brr(m, 3) = "局" & j - 3能取任何单位，并且在单位中有可能碰到跨列居中的请您一并考虑！再次表示衷心的感谢！

zhaogang1960

dtxczjzmp 发表于 2012-1-26 15:45
感谢zhaogang1960老师的关心和帮助！但还有一个小问题那就是brr(m, 3) = "局" & j - 3这一句我不怎么理解 ...

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.     [a5].Resize(m, 4) = brr
    
34.     Application.ScreenUpdating = True
    
35. End Sub
    

复制代码