[已解决]数据统计的VBA求助

安全网

B列的名称是有每日进仓和每日出仓的地名提取，C列的数据是由每日进仓的工作表内对应的地名的数据汇总提取（每日进仓表内K列为空才提取）；D列的数据是由每日出仓的工作表内对应的地名的数据汇总提取（每日出仓表内J列为空才提取）；E列为上月库存的表格内对应的地名的数据提取：F列等月C+E-D列的值的

最佳答案

月排行榜 / 总排行榜

grf1973

2016-3-15 14:39

1. Sub 提取数据()
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.     Dim brr(1 To 1000, 1 To 6)
   
4.     With Sheets("每日出仓")
   
5.         r = .[c65536].End(3).Row
   
6.         arr = .Range("a1:j" & r)
   
7.     End With
   
8.     For i = 3 To UBound(arr)
   
9.         If Len(arr(i, 9)) = 0 And arr(i, 6) > 0 Then
   
10.             x = arr(i, 3)
    
11.             If Not d.exists(x) Then
    
12.                 n = n + 1
    
13.                 d(x) = n
    
14.                 brr(n, 1) = n
    
15.                 brr(n, 2) = x
    
16.             End If
    
17.             brr(d(x), 4) = brr(d(x), 4) + arr(i, 6)
    
18.         End If
    
19.     Next
    
20.    
    
21.     With Sheets("每日进仓")
    
22.         r = .[e65536].End(3).Row
    
23.         arr = .Range("a1:k" & r)
    
24.     End With
    
25.     For i = 3 To UBound(arr)
    
26.         If Len(arr(i, 11)) = 0 And arr(i, 8) > 0 Then
    
27.             x = arr(i, 5)
    
28.             If Not d.exists(x) Then
    
29.                 n = n + 1
    
30.                 d(x) = n
    
31.                 brr(n, 1) = n
    
32.                 brr(n, 2) = x
    
33.             End If
    
34.             brr(d(x), 3) = brr(d(x), 3) + arr(i, 8)
    
35.         End If
    
36.     Next
    
37.    
    
38.     With Sheets("上月库存")
    
39.         r = .[b65536].End(3).Row
    
40.         arr = .Range("a1:c" & r)
    
41.     End With
    
42.     For i = 3 To UBound(arr)
    
43.         x = arr(i, 2)
    
44.         If d(x) > 0 Then brr(d(x), 5) = arr(i, 3)
    
45.     Next
    
46.    
    
47.     [a3:f1000] = ""
    
48.     [a3].Resize(n, 6) = brr
    
49.     [f3].Resize(n, 1).Formula = "=rc[-3]+rc[-1]-rc[-2]"
    
50. End Sub

复制代码

跳转到最佳答案楼层

grf1973

1. Sub 提取数据()
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.     Dim brr(1 To 1000, 1 To 6)
   
4.     With Sheets("每日出仓")
   
5.         r = .[c65536].End(3).Row
   
6.         arr = .Range("a1:j" & r)
   
7.     End With
   
8.     For i = 3 To UBound(arr)
   
9.         If Len(arr(i, 9)) = 0 And arr(i, 6) > 0 Then
   
10.             x = arr(i, 3)
    
11.             If Not d.exists(x) Then
    
12.                 n = n + 1
    
13.                 d(x) = n
    
14.                 brr(n, 1) = n
    
15.                 brr(n, 2) = x
    
16.             End If
    
17.             brr(d(x), 4) = brr(d(x), 4) + arr(i, 6)
    
18.         End If
    
19.     Next
    
20.    
    
21.     With Sheets("每日进仓")
    
22.         r = .[e65536].End(3).Row
    
23.         arr = .Range("a1:k" & r)
    
24.     End With
    
25.     For i = 3 To UBound(arr)
    
26.         If Len(arr(i, 11)) = 0 And arr(i, 8) > 0 Then
    
27.             x = arr(i, 5)
    
28.             If Not d.exists(x) Then
    
29.                 n = n + 1
    
30.                 d(x) = n
    
31.                 brr(n, 1) = n
    
32.                 brr(n, 2) = x
    
33.             End If
    
34.             brr(d(x), 3) = brr(d(x), 3) + arr(i, 8)
    
35.         End If
    
36.     Next
    
37.    
    
38.     With Sheets("上月库存")
    
39.         r = .[b65536].End(3).Row
    
40.         arr = .Range("a1:c" & r)
    
41.     End With
    
42.     For i = 3 To UBound(arr)
    
43.         x = arr(i, 2)
    
44.         If d(x) > 0 Then brr(d(x), 5) = arr(i, 3)
    
45.     Next
    
46.    
    
47.     [a3:f1000] = ""
    
48.     [a3].Resize(n, 6) = brr
    
49.     [f3].Resize(n, 1).Formula = "=rc[-3]+rc[-1]-rc[-2]"
    
50. End Sub

复制代码