[已解决]求VBA

lkjpoi

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

2012-5-25 09:22 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

hrpotter

2012-5-25 11:58

lkjpoi 发表于 2012-5-25 11:52
是这样,但重数不能用 = 2,我时常会变动数,用大于且小于通用强,一点小变动我也不懂.

1. Sub test()
   
2.     Dim ar, br, cr, dr(1 To 1000, 1 To 1)
   
3.     Dim i As Integer, j As Integer, k As Integer
   
4.     Dim d As Object
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     ar = Range("d11").CurrentRegion
   
7.     For j = 1 To UBound(ar, 2)
   
8.         If Cells(9, 3 + j) <> "" Then
   
9.             For i = 1 To UBound(ar)
   
10.                 If ar(i, j) <> "" Then
    
11.                     d(ar(i, j)) = d(ar(i, j)) + 1
    
12.                 End If
    
13.             Next
    
14.         End If
    
15.     Next
    
16.     br = d.keys
    
17.     cr = d.items
    
18.     For i = 0 To UBound(cr)
    
19.         If cr(i) > 1 And cr(i) < 3 Then   '这边改
    
20.             k = k + 1
    
21.             dr(k, 1) = br(i)
    
22.         End If
    
23.     Next
    
24.     Range("a11:a65536").Clear
    
25.     If k > 0 Then
    
26.         Range("a11").Resize(k, 1).NumberFormatLocal = "@"
    
27.         Range("a11").Resize(k, 1) = dr
    
28.     End If
    
29. End Sub

复制代码

跳转到最佳答案楼层

lkjpoi

是不是超出了vba的范围还是没看懂?

xpw6061

lkjpoi 发表于 2012-5-25 11:21
是不是超出了vba的范围还是没看懂?

水平太低,实在不明白,只能瞪眼
看D9:K9有几格有数,就求出下面几列总数的重复数大于1小于3的数结果显示在A11列
估计是超出了vba的范围

hrpotter

是不是这样，请测试

1. Sub test()
   
2.     Dim ar, br, cr, dr(1 To 1000, 1 To 1)
   
3.     Dim i As Integer, j As Integer, k As Integer
   
4.     Dim d As Object
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     ar = Range("d11").CurrentRegion
   
7.     For j = 1 To UBound(ar, 2)
   
8.         If Cells(9, 3 + j) <> "" Then
   
9.             For i = 1 To UBound(ar)
   
10.                 If ar(i, j) <> "" Then
    
11.                     d(ar(i, j)) = d(ar(i, j)) + 1
    
12.                 End If
    
13.             Next
    
14.         End If
    
15.     Next
    
16.     br = d.keys
    
17.     cr = d.items
    
18.     For i = 0 To UBound(cr)
    
19.         If cr(i) = 2 Then
    
20.             k = k + 1
    
21.             dr(k, 1) = br(i)
    
22.         End If
    
23.     Next
    
24.     Range("a11:a65536").Clear
    
25.     If k > 0 Then
    
26.         Range("a11").Resize(k, 1).NumberFormatLocal = "@"
    
27.         Range("a11").Resize(k, 1) = dr
    
28.     End If
    
29. End Sub

复制代码

wurl

你是要找d9, d9和h9在下面的重复次数吗， 还是？， 不太明白问题，

lkjpoi

hrpotter 发表于 2012-5-25 11:35
是不是这样，请测试

是这样,但重数不能用 = 2,我时常会变动数,用大于且小于通用强,一点小变动我也不懂.

hrpotter

lkjpoi 发表于 2012-5-25 11:52
是这样,但重数不能用 = 2,我时常会变动数,用大于且小于通用强,一点小变动我也不懂.

1. Sub test()
   
2.     Dim ar, br, cr, dr(1 To 1000, 1 To 1)
   
3.     Dim i As Integer, j As Integer, k As Integer
   
4.     Dim d As Object
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     ar = Range("d11").CurrentRegion
   
7.     For j = 1 To UBound(ar, 2)
   
8.         If Cells(9, 3 + j) <> "" Then
   
9.             For i = 1 To UBound(ar)
   
10.                 If ar(i, j) <> "" Then
    
11.                     d(ar(i, j)) = d(ar(i, j)) + 1
    
12.                 End If
    
13.             Next
    
14.         End If
    
15.     Next
    
16.     br = d.keys
    
17.     cr = d.items
    
18.     For i = 0 To UBound(cr)
    
19.         If cr(i) > 1 And cr(i) < 3 Then   '这边改
    
20.             k = k + 1
    
21.             dr(k, 1) = br(i)
    
22.         End If
    
23.     Next
    
24.     Range("a11:a65536").Clear
    
25.     If k > 0 Then
    
26.         Range("a11").Resize(k, 1).NumberFormatLocal = "@"
    
27.         Range("a11").Resize(k, 1) = dr
    
28.     End If
    
29. End Sub

复制代码