[已解决]改动个vba

kijx · 发表于 2012-6-19 18:12

把重数大于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

最佳答案

月排行榜 / 总排行榜

hrpotter

2012-6-19 18:52

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

复制代码

跳转到最佳答案楼层

hrpotter · 发表于 2012-6-19 18:52

这个最佳答案由 hrpotter 给出，感谢 hrpotter 的回答。

单击隐藏图章

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

复制代码

		自动登录	找回密码
密码			注册