[已解决]请高手帮着看看这个程序怎么了

dtzbf

Sub gg()
Dim qp(1 To 10000, 1 To 3)
Dim hs
Dim arr, x As Integer, sr As String, k As Integer
Dim dd 'As New Dictionary
Set dd = CreateObject("scripting.dictionary")
arr = Sheets2.Range("b3:d" & Range("d65536").End(xlUp).Row)
For x = 1 To UBound(arr)
    sr = arr(x, 1) & "-" & arr(x, 2)
    If dd.Exists(sr) Then
      hs = dd(sr)
      qp(hs, 3) = qp(hs, 3) ' + arr(x, 3)
    Else
      k = k + 1
      dd(sr) = k
     qp(k, 1) = arr(x, 1)
      qp(k, 2) = arr(x, 2)
      qp(k, 3) = arr(x, 3)
         End If
Next x
   Sheet4.Range("b6").Resize(k, 3) = qp
  dd.RemoveAll
End Sub
此程序出不重复值，运行一次出几条记录，不知道是什么问题，请高手指点一下。

最佳答案

月排行榜 / 总排行榜

zjdh

2013-8-8 18:05

(, 下载次数: 9)

上传

点击文件名下载附件

跳转到最佳答案楼层

zjdh

是统计重复次数吗？

dtzbf

zjdh 发表于 2013-8-6 17:19
是统计重复次数吗？

不是，提取不重复的值。

爱疯

“此程序出不重复值，运行一次出几条记录”这句话是什么意思？

建议上传附件

从从容容

Dim dd 'As New Dictionary 改为Dim dd As New Dictionary

从从容容

1. Sub gg()
   
2. Dim qp(1 To 10000, 1 To 3)
   
3. Dim hs
   
4. Dim arr, x As Integer, sr As String, k As Integer
   
5. Dim dd As New Dictionary
   
6. Set dd = CreateObject("scripting.dictionary")
   
7. arr = Sheets2.Range("b3:d" & Range("d65536").End(xlUp).Row)
   
8. For x = 1 To UBound(arr)
   
9.     sr = arr(x, 1) & "-" & arr(x, 2)
   
10.     If dd.Exists(sr) Then
    
11.       hs = dd(sr)
    
12.       qp(hs, 3) = qp(hs, 3) ' + arr(x, 3)
    
13.     Else
    
14.       k = k + 1
    
15.       dd(sr) = k
    
16.      qp(k, 1) = arr(x, 1)
    
17.       qp(k, 2) = arr(x, 2)
    
18.       qp(k, 3) = arr(x, 3)
    
19.          End If
    
20. Next x
    
21.    Sheet4.Range("b6:d" & sheets(4).cells(rows.count,2).end(3).row+1).clearcontents
    
22.    Sheet4.Range("b6").Resize(k, 3) = qp
    
23. End Sub

复制代码

zjdh

创建字典的两个方法
1 引用 c:\windows\system32\scrrun.dll  控件：Microsoft Scripting Runtime
   然后 Dim d as new Dictionary  -------------引用法
2 Set d = CreateObject("Scripting.Dictionary") --------------创建法

zjdh

dtzbf 发表于 2013-8-7 08:28
不是，提取不重复的值。

还是不懂你的意思！
是获得每个不重复值之和，还是仅获得不重复。
传个附件加点说明！

dtzbf

附件：请高手查看

zjdh

用你的宏稍作修改即可：
Sub TQ()
    Sheets("库存").Range("B3:D65536").ClearContents
    Set dd = CreateObject("scripting.dictionary")
    arr = Sheets("入库表").Range("B3:D" & Sheets("入库表").Range("D65536").End(xlUp).Row)
    For x = 1 To UBound(arr)
        sr = arr(x, 1) & "-" & arr(x, 2)
        If Not dd.Exists(sr) Then
            dd(sr) = ""
            k = k + 1
            arr(k, 1) = arr(x, 1)
            arr(k, 2) = arr(x, 2)
            arr(k, 3) = arr(x, 3)
        End If
    Next x
    Sheets("库存").Range("B3").Resize(k, 3) = arr
End Sub
提取多列不重复字段.rar (36.18 KB, 下载次数: 10)

2013-8-7 20:41 上传

点击文件名下载附件