求助在一张表内提取不同表的数据实现两表勾稽关系校验功能

dagal

为了更快的审核2张报表间的勾稽关系，原来的模式是在C表中设置一张验证表，是使用链接的方式加加减减，有时发现校验不为零时还需查询公式中指向哪个单元格再去查看具体错误，每月初上交的部门报表较多，希望在附件中的校验表中输入场所代码即提取相关数据并自动完成校验，谢谢大神帮忙 校验.rar (83.98 KB, 下载次数: 38)

2018-7-16 00:10 上传

点击文件名下载附件

opiona

还是遍历循环的问题！

zhenghui13

我这边附件无法解压缩

dagal

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr, vs(1 To 3)
   
4.   Dim wb As Workbook
   
5.   Dim ws As Worksheet
   
6.   Dim mypath$, myname$
   
7.   Dim d As Object
   
8.   Set d = CreateObject("scripting.dictionary")
   
9.   vs(1) = [{5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,25,26,28,29,32}]
   
10.   vs(2) = [{5,6,7,8,9,10,11,12,48,49,50,51,52,56,57,60,61,62,65}]
    
11.   vs(3) = [{23,32}]
    
12.   With Worksheets("sheet1")
    
13.     dm = .Range("g1")
    
14.     arr = .Range("a3:g26")
    
15.   End With
    
16.   mypath = ThisWorkbook.Path & ""
    
17.   wjj = "1806-" & dm & "报表"
    
18.   If Dir(mypath & wjj, vbDirectory) = "" Then
    
19.     MsgBox mypath & wjj & "不存在！"
    
20.     Exit Sub
    
21.   End If
    
22.   k = 0
    
23.   For Each aa In Array("1806-" & dm & "C表", "1806-" & dm & "B表", "1806-" & dm & "资产负债表")
    
24.     k = k + 1
    
25.     wjm = mypath & wjj & "" & aa & ".xls"
    
26.     If Dir(wjm) <> "" Then
    
27.       Set wb = GetObject(wjm)
    
28.       With wb
    
29.         With .Worksheets("汇总")
    
30.           Select Case k
    
31.             Case 1
    
32.               brr = .Range("a1:m34")
    
33.             Case 2
    
34.               brr = .Range("a1:m65")
    
35.             Case 3
    
36.               brr = .Range("a1:f39")
    
37.           End Select
    
38.           For j = 1 To UBound(vs(k))
    
39.             If k <= 2 Then
    
40.               arr(j, k * 2) = brr(vs(k)(j), 3)
    
41.             Else
    
42.               arr(j, 6) = brr(vs(k)(j), 2)
    
43.               arr(j, 7) = brr(vs(k)(j), 3)
    
44.             End If
    
45.           Next
    
46.         End With
    
47.         .Close False
    
48.       End With
    
49.     End If
    
50.   Next
    
51.   With Worksheets("sheet1")
    
52.     .Range("a3").Resize(UBound(arr), UBound(arr, 2)) = arr
    
53.   End With
    
54. End Sub

复制代码

感谢 chxw68 提供帮助！