vba ，提取不重复值 后统计重复次数，并判断每个不重复值之间的重复次数是否相等

Question

求vba编写代码，在一列数据中提取不重复值，并显示每一个不重复值的重复次数。

（列号） C D .........
（表头） 类型 颜色 .........
(行号) 4 （空值） 红色 ........
5 （空值） 红色 ........
6 高频 ........
7 高频
8 高频
9 （空值） 黑色
10 低频 黑色
11 低频
12 低频
13 低频
.. ....
求VBA代码编写后得①：（行号） C D
高频-10（数，是指重复次数） 红色-2 （提取本列不重复值-重复次数）
低频-4 黑色-2
②： False Ture (判断重复次数相等)
补充：求得的信息显示在另一新建文件里

先谢谢啦~

Answer 1

亲，打开你的Excel文件，按“Alt+F11”打开VBA编辑窗口，然后在左侧空白处点击右键，“插入”，“模块”。右侧空白处粘贴下面的代码。关闭VBA窗口。然后按“Alt+F8”打开宏窗口，选择刚插入的宏，点击“执行”。

 

运行后，将新建一个工作簿，存放结果。

 

Sub pc()
Dim d, k
Set d = CreateObject("Scripting.Dictionary")
Dim rg As Range, c, r, n As Long
Workbooks.Add
ActiveWorkbook.ActiveSheet.Range("C1:D1").Value = Array("类型", "颜色")
With ThisWorkbook.ActiveSheet
    For c = 3 To 4
        r = .Cells(Rows.Count, c).End(xlUp).Row
        For Each rg In .Cells(4, c).Resize(r - 3)
            If rg.Value <> "" Then d(rg.Value) = d(rg.Value) + 1
        Next
        r = ActiveWorkbook.ActiveSheet.Cells(Rows.Count, c).End(xlUp).Row: n = 1
        For Each k In d.keys
            n = n + 1
            ActiveWorkbook.ActiveSheet.Cells(n, c).Value = k & "-" & d(k)
        Next
        d.RemoveAll
    Next
End With
Set d = Nothing
End Sub

追问

如果内容信息变了，此代码仍可行吗

追答

代码只统计C、D两列，从第4行开始，一直到你实际数据结束行。

追问

因为看到。Array("类型", "颜色")内容，所以想问，可以不可以把类型和颜色用其他表示形式替换，

追答

噢，这个只是写个表头而已，你可以更改

追问

那数据很多的情况下，我还要把表头一一写上吗？，这样有点麻烦耶

追答

不理解……你是说要统计很多列吗？如果统计列很多，可以改一下代码把首行标题复制到新表；不过，如果你增加列的话，循环变量c的起止要改。如果你是这个意思，可以追问我修订代码。

追问

嗯，是要循环很多列，但不确定后期是否会增加列，求代码

追答

代码见附件：
http://pan.baidu.com/s/1gdpebIV

追问

还是这句有问题

追答

把你的实际数据截图上来看看，我怀疑你实际数据情况和你原题贴上来的不一样。截图务必带上行号和列标！

Answer 2

你这个结果说明了原始的C列和D列没有任何关系呀，对吗？