[已解决]请哪位高手帮助修改代码。急急！！！

ymq123

把工作表1中所有重复行数最多的行选出来填在工作表2中。表格内容选少可以执行操作，但内容选多就不能执行操作，不知什么原因，请哪位高手帮帮忙。在工作表里举的有例子。谢谢！

最佳答案

月排行榜 / 总排行榜

su45

2013-6-10 11:17

Private Sub 选相同_Click()
Range("a1:m40000") = ""
Dim sh As Worksheet
Dim d As Object, sr As String
Set sh = Sheets("1")
Set d = CreateObject("scripting.dictionary")
k = 0
For x = 1 To 7703
    sr = ""
    For y = 1 To 10
        sr = sr & "-" & Replace(sh.Cells(x, y), " ", "")
    Next y
    If sr <> "----------" Then
        d(sr) = d(sr) + 1
    End If
Next x
arr = d.keys
arr1 = d.items
m = Application.Max(arr1)
For x = 0 To UBound(arr1)
If arr1(x) = m Then
   k = k + 1
   arr2 = Split(arr(x), "-")
   For y = 1 To 10
    Cells(k, y) = arr2(y)
   Next y
End If
Next x
End Sub

跳转到最佳答案楼层

su45

Private Sub 选相同_Click()
Range("a1:m40000") = ""
Dim sh As Worksheet
Dim d As Object, sr As String
Set sh = Sheets("1")
Set d = CreateObject("scripting.dictionary")
k = 0
For x = 1 To 7703
    sr = ""
    For y = 1 To 10
        sr = sr & "-" & Replace(sh.Cells(x, y), " ", "")
    Next y
    If sr <> "----------" Then
        d(sr) = d(sr) + 1
    End If
Next x
arr = d.keys
arr1 = d.items
m = Application.Max(arr1)
For x = 0 To UBound(arr1)
If arr1(x) = m Then
   k = k + 1
   arr2 = Split(arr(x), "-")
   For y = 1 To 10
    Cells(k, y) = arr2(y)
   Next y
End If
Next x
End Sub

ymq123

su45 发表于 2013-6-10 11:17
Private Sub 选相同_Click()
Range("a1:m40000") = ""
Dim sh As Worksheet

你好：还麻烦你一下：在工作表1中又另加一个表格，把它们最多相同行同时选出放在工作表2中，这时代码不正常运行，请修改。谢谢！
Private Sub 选相同_Click()
Range("a1:m40000") = ""
Dim sh As Worksheet
Dim d As Object, sr As String
Set sh = Sheets("1")
Set d = CreateObject("scripting.dictionary")
k = 0
For Z = 0 To 1
For x = 1 To 7703
    sr = ""
    For y = 1 To 10
        sr = sr & "-" & Replace(sh.Cells(x, y + 14 * Z), " ", "")
    Next y
    If sr <> "----------" Then
        d(sr) = d(sr) + 1
    End If
Next x
arr = d.keys
arr1 = d.items
m = Application.Max(arr1)
For x = 0 To UBound(arr1)
If arr1(x) = m Then
   k = k + 1
   arr2 = Split(arr(x), "-")
   For y = 1 To 10
    Cells(k, y + 14 * Z) = arr2(y)
   Next y
End If
Next x
Next Z
End Sub

su45

你把增加的东东，重新开个帖子，提供附件及说明！

ymq123

su45 发表于 2013-6-10 18:33
你把增加的东东，重新开个帖子，提供附件及说明！

你好：我的的帖子已经发了请帮助修改。谢谢！