完善数组，brr数组第三五列怎么生成

yjh_27

weiyingde 发表于 2017-11-5 12:26
谢谢，我试试，不行你在帮我看看。

只解决第二次计算时，字典重置，使用一个字典。不然第二计算会出错。

microyip

weiyingde 发表于 2017-11-5 12:26
谢谢，我试试，不行你在帮我看看。

在获取vData之后，要把已经使用的字典进行清理，oDic.Removeall

weiyingde

yjh_27 发表于 2017-11-5 12:32
只解决第二次计算时，字典重置，使用一个字典。不然第二计算会出错。

字典能用变量表示吗？
能否这样解决？
Set oDic1 = CreateObject("Scripting.Dictionary")
Set oDic 2= CreateObject("Scripting.Dictionary")
For i = 1 To 2
   IF i =1 then Set oDic =  oDic1  else set oDic =  oDic2
   vData = Sheets(i).[a1].CurrentRegion.Value
   

weiyingde

microyip 发表于 2017-11-5 12:36
在获取vData之后，要把已经使用的字典进行清理，oDic.Removeall

在你的源代码中已经有了这一句，
ReDim vFill(1 To nFill, 1 To 5)
        oDic.RemoveAll
        For vRow = 1 To nFill
是这一句吗？

weiyingde

microyip 发表于 2017-11-5 12:36
在获取vData之后，要把已经使用的字典进行清理，oDic.Removeall

我改为：dim oDic1 As Object, oDic2 As Object
Set oDic1 = CreateObject("Scripting.Dictionary")
Set oDic2 = CreateObject("Scripting.Dictionary")

    For i = 1 To 2
    If i = 1 Then Set oDic = oDic1 Else Set oDic = oDic2
……
还是出问题，不知为何？

liulang0808

1. Sub 按钮1_Click()
   
2.     Dim brr()
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Application.ScreenUpdating = False
   
5.     arr = [a1].CurrentRegion
   
6.     a = 1
   
7.     For j = 2 To UBound(arr)
   
8.         If d.exists(arr(j, 1)) Then
   
9.             r = d(arr(j, 1))
   
10.             brr(2, r) = 1 + brr(2, r)
    
11.             brr(3, r) = brr(3, r) & j & ","
    
12.             brr(4, r) = arr(j, 6) + brr(4, r)
    
13.         Else
    
14.             ReDim Preserve brr(1 To 5, 1 To a)
    
15.             brr(1, a) = arr(j, 1)
    
16.             brr(2, a) = 1
    
17.             brr(3, a) = j & ","
    
18.             brr(4, a) = arr(j, 6)
    
19.             brr(5, a) = a
    
20.             d(arr(j, 1)) = a
    
21.             a = a + 1
    
22.         End If
    
23.     Next j
    
24.     For j = 1 To a - 1
    
25. 
    
26.         d.RemoveAll
    
27.         crr = Split(brr(3, j), ",")
    
28.         For i = 0 To UBound(crr) - 1
    
29.             d(arr(crr(i), 5)) = ""
    
30.         Next i
    
31.         brr(3, j) = d.Count
    
32.     Next j
    
33.    
    
34.     For j = 1 To a - 1
    
35.         For i = j + 1 To a - 1
    
36.             If brr(4, j) < brr(4, i) Then
    
37.                For l = 1 To 4
    
38.                     tmp = brr(l, i)
    
39.                     brr(l, i) = brr(l, j)
    
40.                     brr(l, j) = tmp
    
41.                Next l
    
42.             End If
    
43.         Next i
    
44.     Next j
    
45.     [j2].Resize(a - 1, 5) = WorksheetFunction.Transpose(brr)
    
46.     Columns("j:j").Replace " ", ""
    
47.     For j = 0 To 9
    
48.         Columns("j:j").Replace j, ""
    
49.         
    
50.     Next j
    
51.     Application.ScreenUpdating = True
    
52.    
    
53. End Sub
    

复制代码

liulang0808

看看是否满足需求吧

weiyingde

谢谢各位，在开头加一个
On error resume next
有了结果，可是第二张表从第13个开始的，是接着第一张表的。

weiyingde

liulang0808 发表于 2017-11-5 13:11
看看是否满足需求吧

多次得到版主的指导，非常感谢！！谢谢你费心了！！！
你的代码加上microyip大侠的，我已经收获了两种思路，非常庆幸。

现在我想从两张规格相同的表格得到两个数组，而这两个数组，我将要在PPt VBA中调用。
事实上，这段代码也是要写在ppt模块中。除了最初获取数组对应的数据区域时，调用excel外，为了ppt的运行速度，一旦完成两个数组的创建后，立即断开与Excel数据源工作表的关联，并关闭Excel程序。
最后的在ppt中调用所生成的结果图如下。在microyip大侠帮助下，已完成部分任务，也就是本次统计。
还有全期统计，表格规格和“本期统计”一样，所以我想对microyip大侠的代码稍加修改，实现一个过程完成从两张表格生成两个数组的任务。
大抵能运行，只是第二数组丢失了与第一数组等量的数据。是不是调用字典的原因呢？找了很长时间，不断测试，始终没有结果。不知何故——郁闷呀！！我将附件呈上，你帮我看看。
谢谢你的帮助，期盼你的回复。

weiyingde

一过程“一箭双雕”创建两数组，第二数组丢失了与第一数组等量的数据.zip (39.01 KB, 下载次数: 4)

2017-11-5 14:08 上传

点击文件名下载附件

liulang0808 发表于 2017-11-5 13:11
看看是否满足需求吧

方便的话，求你指点，排忧解难。
附件如下：