[已解决]数组输出

张雄友

数组输出办法。

最佳答案

月排行榜 / 总排行榜

dsmch

2014-2-15 10:05

1. Sub Macro1()
   
2. Dim arr, brr, d, i&, s&
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = Range("b10:b" & Range("b65536").End(xlUp).Row)
   
5. x = Application.WorksheetFunction.CountIf(Columns(2), "期间")
   
6. ReDim brr(1 To UBound(arr), 1 To 1)
   
7. For i = 1 To UBound(arr)
   
8.     If arr(i, 1) <> "" Then d(arr(i, 1)) = d(arr(i, 1)) + 1
   
9.     If d(arr(i, 1)) = x Then s = s + 1: brr(s, 1) = arr(i, 1)
   
10. Next
    
11. Range("c1").Resize(s) = brr
    
12. End Sub
    

复制代码

不判断期间的话

跳转到最佳答案楼层

风林火山

Sub 找出B列的重复值()    '每组都有的,因为B列中有很多组数据
    Dim Arr, i&, Myr&, n&, Arr1(), r&, Arr2()
    Dim d, k, t, ks, js, j&
    Set d = CreateObject("Scripting.Dictionary")
    [C:C].ClearContents
    Myr = Cells(Rows.Count, 2).End(xlUp).Row
    Arr = Range("B1:B" & Myr)
    For i = 1 To UBound(Arr)
        If Arr(i, 1) = "期间" Then
            n = n + 1
            ReDim Preserve Arr1(1 To n)
            Arr1(n) = i
        End If
    Next
    For i = 1 To n
        If i <> n Then
            js = Arr1(i + 1) - 1
        Else
            js = UBound(Arr)
        End If
        ks = Arr1(i) + 1
        For j = ks To js
            If Arr(j, 1) <> "" Then
                d(Arr(j, 1)) = d(Arr(j, 1)) + 1
            End If
        Next
    Next
    k = d.keys: t = d.items
    ReDim Preserve Arr2(1 To Cells(Rows.Count, 2).End(3).Row, 1 To 1)
    For i = 0 To UBound(k)
        If t(i) = n Then
            r = r + 1
            Arr2(r, 1) = k(i)
        End If
    Next
    [C1] = "期间"
    [C2].Resize(r, 1) = Arr2
End Sub

张雄友

风林火山 发表于 2014-2-14 19:27
Sub 找出B列的重复值()    '每组都有的,因为B列中有很多组数据
    Dim Arr, i&, Myr&, n&, Arr1(), r&, A ...

ReDim Preserve Arr2(1 To Cells(Rows.Count, 2).End(3).Row, 1 To 1)??

ReDim Preserve  比  ReDim 要慢吧？

风林火山

ReDim Arr2(1 To Cells(Rows.Count, 2).End(3).Row, 1 To 1)
删掉吧，楼主是高手，你明白的，的确慢

dsmch

1. Sub Macro1()
   
2. Dim arr, brr, d, i&, s&
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = Range("b10:b" & Range("b65536").End(xlUp).Row)
   
5. ReDim brr(1 To UBound(arr), 1 To 1)
   
6. s = 1: brr(s, 1) = "期间"
   
7. For i = 1 To UBound(arr)
   
8.     If arr(i, 1) <> "期间" Then d(arr(i, 1)) = d(arr(i, 1)) + 1
   
9.     If d(arr(i, 1)) = 2 Then s = s + 1: brr(s, 1) = arr(i, 1)
   
10. Next
    
11. Range("c1").Resize(s) = brr
    
12. End Sub
    

复制代码

张雄友

dsmch 发表于 2014-2-14 19:36

'每组都有的才算重复,因为B列中有很多组数据，而且答案出现了空值。

dsmch

1. Sub Macro1()
   
2. Dim arr, brr, d, i&, s&
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = Range("b10:b" & Range("b65536").End(xlUp).Row)
   
5. x = Application.WorksheetFunction.CountIf(Columns(2), "期间")
   
6. ReDim brr(1 To UBound(arr), 1 To 1)
   
7. s = 1: brr(s, 1) = "期间"
   
8. For i = 1 To UBound(arr)
   
9.     If arr(i, 1) <> "期间" And arr(i, 1) <> "" Then d(arr(i, 1)) = d(arr(i, 1)) + 1
   
10.     If d(arr(i, 1)) = x Then s = s + 1: brr(s, 1) = arr(i, 1)
    
11. Next
    
12. Range("c1").Resize(s) = brr
    
13. End Sub
    

复制代码

如果每组没有重复

tgydslr

赏析一下不错

张雄友

（风林火山，dsmch），都是最佳，问题解决了。谢谢大家！

风林火山

张雄友 发表于 2014-2-14 19:58
（风林火山，dsmch），都是最佳，问题解决了。谢谢大家！

把最佳给他