excel吧 关注：281,910贴子：1,556,116
- 18回复贴，共1页
不感兴趣
开通SVIP免广告
菠萝蜜
'看上去长得有点象
Option Explicit
Sub abc()
Dim a, i, j, m, p, d(1)
For i = 0 To UBound(d)
Set d(i) = CreateObject("scripting.dictionary")
Next
a = Range("d2:i" & [d2].End(xlDown).Row).Value
ReDim b(1 To UBound(a), 1 To 2)
For i = 1 To UBound(a)
For j = 1 To UBound(a, 2)
d(0)(a(i, j)) = d(0)(a(i, j)) + 1
If d(0)(a(i, j)) = 6 And Not d(1).exists(a(i, j)) Then
d(1)(a(i, j)) = 1
m = m + 1
b(m, 1) = "行2-行" & i + 1: b(m, 2) = a(i, j)
End If
Next
Next
For i = 1 To m
If b(i, 1) <> b(i + 1, 1) Then
Call bsort(b, p + 1, i, 2, 2, 2)
p = i
End If
Next
[l2].Resize(UBound(b), 2) = b
End Sub
Function bsort(a, first, last, left, right, key)
Dim i, j, k, t
For i = first To last - 1
For j = first To last + first - 1 - i
If a(j, key) > a(j + 1, key) Then
For k = left To right
t = a(j, k): a(j, k) = a(j + 1, k): a(j + 1, k) = t
Next
End If
Next
Next
End Function
Sub 出现次数()
Dim dic As Object
Dim r%, i%, j%
Dim arr As Variant
Set dic = CreateObject("scripting.dictionary")
r = Range("i1048576").End(xlUp).Row
arr = Range("d2:i" & r)
For i = 1 To UBound(arr, 1)
For j = 1 To UBound(arr, 2)
dic(arr(i, j)) = dic(arr(i, j)) + 1
If dic(arr(i, j)) = 6 Then
c = Range("p1048576").End(xlUp).Row + 1
Range("p" & c) = arr(i, j)
End If
Next j
Next i
End Sub
Dim dic As Object
Dim r%, i%, j%
Dim arr As Variant
Set dic = CreateObject("scripting.dictionary")
r = Range("i1048576").End(xlUp).Row
arr = Range("d2:i" & r)
For i = 1 To UBound(arr, 1)
For j = 1 To UBound(arr, 2)
dic(arr(i, j)) = dic(arr(i, j)) + 1
If dic(arr(i, j)) = 6 Then
c = Range("p1048576").End(xlUp).Row + 1
Range("p" & c) = arr(i, j)
End If
Next j
Next i
End Sub
