[已解决]求助VBA

uuw5

Book1.rar (8.38 KB, 下载次数: 14)

2013-9-21 00:43 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2013-9-21 07:34

1. Sub test()
   
2.     Dim arr, arr2(1 To 1000, 1 To 1), k As Integer
   
3.     Dim lLastRow As Long
   
4.     lLastRow = Cells(Rows.Count, "f").End(xlUp).Row
   
5.     arr = Range(Range("f2"), Cells(lLastRow, "g")).Value
   
6.     Dim objDic As Object
   
7.     On Error Resume Next
   
8.     Set objDic = CreateObject("scripting.dictionary")
   
9. 
   
10.     For i = LBound(arr) To UBound(arr) Step 9
    
11.         For j = 0 To 8
    
12.             If Len(arr(i + j, 1)) Then
    
13.                 objDic(arr(i + j, 1)) = objDic(arr(i + j, 1)) + 1
    
14.             End If
    
15.         Next
    
16.         For Each Key In objDic.keys
    
17.             If objDic(Key) > 1 Then
    
18.                 k = k + 1
    
19.                 arr2(k, 1) = "'" & Key
    
20.             End If
    
21.         Next
    
22.         objDic.RemoveAll
    
23.     Next
    
24.     Set objDic = Nothing
    
25.     If k Then
    
26.         Range("h2").Resize(k).Value = arr2
    
27.         MsgBox "数据提取完成"
    
28.     Else
    
29.         MsgBox "没有符合要求的数据"
    
30.     End If
    
31.    
    
32. End Sub

复制代码

跳转到最佳答案楼层

hwc2ycy

直接用字典，9个数据项一统计，一轮完成后，字典清空。

hwc2ycy

1. Sub test()
   
2.     Dim arr, arr2(1 To 1000, 1 To 1), k As Integer
   
3.     Dim lLastRow As Long
   
4.     lLastRow = Cells(Rows.Count, "f").End(xlUp).Row
   
5.     arr = Range(Range("f2"), Cells(lLastRow, "g")).Value
   
6.     Dim objDic As Object
   
7.     On Error Resume Next
   
8.     Set objDic = CreateObject("scripting.dictionary")
   
9. 
   
10.     For i = LBound(arr) To UBound(arr) Step 9
    
11.         For j = 0 To 8
    
12.             If Len(arr(i + j, 1)) Then
    
13.                 objDic(arr(i + j, 1)) = objDic(arr(i + j, 1)) + 1
    
14.             End If
    
15.         Next
    
16.         For Each Key In objDic.keys
    
17.             If objDic(Key) > 1 Then
    
18.                 k = k + 1
    
19.                 arr2(k, 1) = "'" & Key
    
20.             End If
    
21.         Next
    
22.         objDic.RemoveAll
    
23.     Next
    
24.     Set objDic = Nothing
    
25.     If k Then
    
26.         Range("h2").Resize(k).Value = arr2
    
27.         MsgBox "数据提取完成"
    
28.     Else
    
29.         MsgBox "没有符合要求的数据"
    
30.     End If
    
31.    
    
32. End Sub

复制代码

danio112

Sub ÇóÖظ´Öµ()
Set d = CreateObject("scripting.dictionary")
Set t = CreateObject("scripting.dictionary")
Dim arr(1 To 5, 1 To 9)

For i = 1 To 5 '把数据放入数组
For j = 1 To 9
arr(i, j) = Range("f" & (i - 1) * 9 + j + 1)
Next
Next

For i = 1 To 5
For j = 1 To 9
  If arr(i, j) <> "" Then
   If d.exists(arr(i, j)) = True Then　
   t(arr(i, j)) = ""　‘存在则写入另一个字典
   Else
   d(arr(i, j)) = ""
   End If
  End If
Next
d.RemoveAll
n = n + t.Count
Range(Cells(n + 2 - t.Count, 1), Cells(n + 1, 1)) = Application.Transpose(t.keys)　’输出字典
t.RemoveAll
Next

End Sub