[已解决]求改个vba

GYUHJ

Book20.xls.rar (497.74 KB, 下载次数: 6)

2013-7-23 09:36 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

大灰狼1976

2013-7-25 18:52

1. Private Sub CommandButton1_Click()
   
2. Dim arr, arr1, arr2(1 To 100), i&, j%, k As Byte, l As Byte, m As Byte, d As Object, c
   
3. Set d = CreateObject("scripting.dictionary")
   
4. m = 1
   
5. For k = 6 To [iv10].End(1).Column Step 4
   
6.   arr = Range(Cells(10, k), Cells(UsedRange.Rows.Count, k + 3))
   
7.   ReDim arr1(1 To 100)
   
8.   l = 1
   
9.   For j = 1 To 4
   
10.     For i = 1 To UBound(arr)
    
11.      If arr(i, j) <> "" Then d(arr(i, j)) = d(arr(i, j)) + 1
    
12.     Next i
    
13.     For Each c In d.keys
    
14.       If d(c) > 1 Then arr1(l) = c: l = l + 1
    
15.     Next c
    
16.     d.RemoveAll
    
17.   Next j
    
18.   For l = 1 To UBound(arr1)
    
19.     If arr1(l) <> "" Then d(arr1(l)) = d(arr1(l)) + 1
    
20.   Next l
    
21.   For Each c In d.keys
    
22.     If d(c) > 1 Then arr2(m) = c: m = m + 1
    
23.   Next c
    
24.   d.RemoveAll
    
25. Next k
    
26. [a1].Resize(UBound(arr2)) = Application.Transpose(arr2)
    
27. End Sub

复制代码

跳转到最佳答案楼层

大灰狼1976

1. Private Sub CommandButton1_Click()
   
2. Dim arr, arr1, arr2(1 To 100), i&, j%, k As Byte, l As Byte, m As Byte, d As Object, c
   
3. Set d = CreateObject("scripting.dictionary")
   
4. m = 1
   
5. For k = 6 To [iv10].End(1).Column Step 4
   
6.   arr = Range(Cells(10, k), Cells(UsedRange.Rows.Count, k + 3))
   
7.   ReDim arr1(1 To 100)
   
8.   l = 1
   
9.   For j = 1 To 4
   
10.     For i = 1 To UBound(arr)
    
11.      If arr(i, j) <> "" Then d(arr(i, j)) = d(arr(i, j)) + 1
    
12.     Next i
    
13.     For Each c In d.keys
    
14.       If d(c) > 1 Then arr1(l) = c: l = l + 1
    
15.     Next c
    
16.     d.RemoveAll
    
17.   Next j
    
18.   For l = 1 To UBound(arr1)
    
19.     If arr1(l) <> "" Then d(arr1(l)) = d(arr1(l)) + 1
    
20.   Next l
    
21.   For Each c In d.keys
    
22.     If d(c) > 1 Then arr2(m) = c: m = m + 1
    
23.   Next c
    
24.   d.RemoveAll
    
25. Next k
    
26. [a1].Resize(UBound(arr2)) = Application.Transpose(arr2)
    
27. End Sub

复制代码

GYUHJ

大灰狼1976 发表于 2013-7-25 18:52

在我那个附件上会提示错误424,是什么原因?