把重数大于20的条件改成只显示重复个数最多的那个数,
Sub MD20()
Dim ar, br, cr, dr(1 To 1000, 1 To 1)
Dim i As Integer, j As Integer, k As Integer
Dim s As String
Dim d As Object
Dim sh As Worksheet
On Error Resume Next
Set d = CreateObject("scripting.dictionary")
For Each sh In Worksheets
With sh
ar = .Range("e14:aa1121")
For i = 1 To UBound(ar) Step 10
For j = 1 To UBound(ar, 2) - 1
If Left(ar(i, j), 1) <> "" Then
If Left(ar(i, j), 1) - Left(ar(i, j + 1), 1) = 0 Then
s = ""
s = s & Right(10 + Left(ar(i, j + 1), 1) - Left(ar(i + 1, j + 1), 1), 1)
d(s) = d(s) + 1
End If
End If
Next
Next
End With
Next
br = d.keys
cr = d.items
k = 0
For i = 0 To UBound(cr)
If cr(i) > 20 Then
k = k + 1
dr(k, 1) = br(i)
End If
Next
With Sheets(1)
.Range("ar1128:ar1200").ClearContents
.Range("ar1128").Resize(k, 1).NumberFormatLocal = "@"
.Range("ar1128").Resize(k, 1) = dr
End With
End Sub
- Sub MD20()
- Dim ar, br, cr, dr(1 To 1000, 1 To 1)
- Dim i As Integer, j As Integer, k As Integer
- Dim s As String
- Dim d As Object
- Dim sh As Worksheet
- On Error Resume Next
- Set d = CreateObject("scripting.dictionary")
- For Each sh In Worksheets
- With sh
- ar = .Range("e14:aa1121")
- For i = 1 To UBound(ar) Step 10
- For j = 1 To UBound(ar, 2) - 1
- If Left(ar(i, j), 1) <> "" Then
- If Left(ar(i, j), 1) - Left(ar(i, j + 1), 1) = 0 Then
- s = ""
- s = s & Right(10 + Left(ar(i, j + 1), 1) - Left(ar(i + 1, j + 1), 1), 1)
- d(s) = d(s) + 1
- End If
- End If
- Next
- Next
- End With
- Next
- br = d.keys
- cr = d.items
- k = 0
- For i = 0 To UBound(cr)
- If cr(i) = Application.Max(cr) Then '改这里,没附件,自己测试下吧
- k = k + 1
- dr(k, 1) = br(i)
- End If
- Next
- With Sheets(1)
- .Range("ar1128:ar1200").ClearContents
- .Range("ar1128").Resize(k, 1).NumberFormatLocal = "@"
- .Range("ar1128").Resize(k, 1) = dr
- End With
- End Sub
复制代码
|