展开全部
借用下别人的代码
Sub A列取唯一值放在D列后面燃悔显察慎示总计出现败段敬次数()
Dim Arr1()
With ActiveSheet
Rw = .Range("A65536").End(xlUp).Row - 1
Range("d2").Resize(Rw, 2).ClearContents
ArrName = .Range("A2").Resize(Rw, 2)
Set d1 = CreateObject("Scripting.Dictionary")
For i = 1 To Rw
d1(ArrName(i, 1)) = ArrName(i, 1)
Next
n1 = d1.Count
ArrN = Application.Transpose(d1.Keys)
.Range("d2").Resize(n1) = ArrN
For j = 1 To n1
x = 0
For k = 1 To Rw
If ArrName(k, 1) = ArrN(j, 1) Then
x = x + 1
ReDim Preserve Arr1(1 To x)
Arr1(x) = ArrName(k, 2)
End If
Next
c = c + 1
Cells(c + 1, 5) = Application.WorksheetFunction.CountIf(Range("a1:a500"), Cells(c + 1, 4))
Erase Arr1
Next
End With
End Sub
Sub A列取唯一值放在D列后面燃悔显察慎示总计出现败段敬次数()
Dim Arr1()
With ActiveSheet
Rw = .Range("A65536").End(xlUp).Row - 1
Range("d2").Resize(Rw, 2).ClearContents
ArrName = .Range("A2").Resize(Rw, 2)
Set d1 = CreateObject("Scripting.Dictionary")
For i = 1 To Rw
d1(ArrName(i, 1)) = ArrName(i, 1)
Next
n1 = d1.Count
ArrN = Application.Transpose(d1.Keys)
.Range("d2").Resize(n1) = ArrN
For j = 1 To n1
x = 0
For k = 1 To Rw
If ArrName(k, 1) = ArrN(j, 1) Then
x = x + 1
ReDim Preserve Arr1(1 To x)
Arr1(x) = ArrName(k, 2)
End If
Next
c = c + 1
Cells(c + 1, 5) = Application.WorksheetFunction.CountIf(Range("a1:a500"), Cells(c + 1, 4))
Erase Arr1
Next
End With
End Sub
已赞过
已踩过<
评论
收起
你对这个回答的评价是?
推荐律师服务:
若未解决您的问题,请您详细描述您的问题,通过百度律临进行免费专业咨询