在网上看到求区间出现次数的代码，想请各位按我要求修改一下，谢

不感兴趣

开通SVIP免广告

回答你3楼的问题
4楼的问题会更简单一些，你在下面代码的基础上稍作修改即可
Sub ttt()
Dim RNG As Range, r As Range
Dim d As Object, dd As Object
Dim a, b
Dim i%
Set RNG = [B1:F22]
Set d = CreateObject("scripting.dictionary")
For Each r In RNG
If Not d.exists(r.Value) Then
d.Add r.Value, 1
Else
d(r.Value) = CInt(d(r.Value)) + 1
End If
Next
For i = 1 To 100
If Not d.exists(i) Then d.Add i, 0
Next
Set dd = CreateObject("scripting.dictionary")
For i = 0 To d.Count - 1
If Not dd.exists(d.items()(i)) Then
dd.Add d.items()(i), d.keys()(i)
Else
dd(d.items()(i)) = dd(d.items()(i)) & "," & d.keys()(i)
End If
Next i
ReDim a(dd.Count - 1, 1)
For i = 0 To dd.Count - 1
a(i, 0) = dd.keys()(i)
a(i, 1) = dd.items()(i)
Next
b = BS2D(a)
For i = 0 To dd.Count - 1
[G1].Offset(i + 1, 0) = b(i, 0)
[H1].Offset(i + 1, 0) = b(i, 1)
Next
End Sub
Private Function BS2D(arr)
Dim i%, j%, holdInt%, holdFloat As Double
Dim n%: n = UBound(arr)
For i = 0 To n
For j = 0 To n
If arr(j, 0) > arr(i, 0) Then 'ascending
holdFloat = arr(j, 0): holdInt = arr(j, 0)
arr(j, 0) = arr(i, 0): arr(j, 0) = arr(i, 0)
arr(i, 0) = holdFloat: arr(i, 0) = holdInt
End If
Next j
Next i
BS2D = arr
End Function

Option Explicit
Sub abc()
　Dim i, j, t, a, d
　Set d = CreateObject("scripting.dictionary")
　For i = 1 To 100
　　d(i) = 0
　Next
　a = Range("b1:f" & [b1].End(xlDown).Row).Value
　For i = 1 To UBound(a)
　　For j = 1 To UBound(a, 2)
　　　d(a(i, j)) = d(a(i, j)) + 1
　　Next
　Next
　a = Application.Transpose(Array(d.keys, d.items))
　For i = 1 To UBound(a) - 1
　　For j = i + 1 To UBound(a)
　　　If a(i, 2) > a(j, 2) Then
　　　　t = a(i, 1): a(i, 1) = a(j, 1): a(j, 1) = t
　　　　t = a(i, 2): a(i, 2) = a(j, 2): a(j, 2) = t
　　　End If
　　Next
　Next
　[h2].Resize(UBound(a), 2) = a
End Sub

Option Explicit
Sub abc()
　Dim i, j, m, a, d
　Set d = CreateObject("scripting.dictionary")
　a = Range("b1:f" & [b1].End(xlDown).Row).Value
　ReDim b(1 To 100, 1 To 1)
　For i = 1 To UBound(a)
　　For j = 1 To UBound(a, 2)
　　　d(a(i, j)) = 1
　　Next
　Next
　For i = 1 To 100
　　If Not d.exists(i) Then m = m + 1: b(m, 1) = i
　Next
　With [h:h]
　　.ClearContents
　　If m > 0 Then .Resize(m) = b
　End With
End Sub

Sub ccp()
Dim d, arr1
Range("H2:H1000").Clear
Set d = CreateObject("Scripting.Dictionary")
For i = 1 To 100
d(i) = 0
Next
arr1 = Range("B1:F13")
For j = 1 To 5
For k = 1 To 13
If d.Exists(arr1(k, j)) Then
d.Remove (arr1(k, j))
End If
Next
Next
t = d.Keys
[H2].Resize(d.Count, 1) = Application.Transpose(t)
Set d = Nothing
End Sub

不感兴趣

开通SVIP免广告

只会那么点公式

试试

扫二维码下载贴吧客户端

下载贴吧APP
看高清直播、视频！

16回复贴，共1页

<<返回excel吧

分享到:

日	一	二	三	四	五	六