【字典与数组二期1班】第一讲作业数组去重（选做）【已开贴】

csmctjg

重做！

1. 
   
2. Sub csmctjg()
   
3. Dim arr, arr1(1 To 1000) As Integer, arr2(1 To 1000, 1 To 1) As Integer, i&, k&
   
4. arr = Range("A1:A" & [A65536].End(xlUp).Row)
   
5. For i = 1 To UBound(arr)
   
6.     If arr1(arr(i, 1)) = 0 Then
   
7.         arr1(arr(i, 1)) = 1
   
8.         k = k + 1
   
9.         arr2(k, 1) = arr(i, 1)
   
10.     End If
    
11. Next i
    
12. [C1].Resize(k) = arr2
    
13. End Sub
    

复制代码

sunjing-zxl

【字典2班.012】sunjing-zxl  交作业

1. Sub sunjing_zxl()
   
2.     Dim arr1, arr2(), arr3(), n As Long, i As Long
   
3.     Dim str As String, m As Long
   
4.     n = [A65536].End(xlUp).Row
   
5.     Range("C1:C65536").ClearContents
   
6.     arr1 = Range("A1:A" & n)
   
7.     ReDim arr2(1 To n, 1 To 1)
   
8.     ReDim arr3(n)
   
9.     For i = 1 To n
   
10.         str = Join(arr3, ",")
    
11.         If InStr(1, str, "," & arr1(i, 1) & ",", 0) = 0 Then
    
12.             m = m + 1
    
13.             arr2(m, 1) = arr1(i, 1)
    
14.             arr3(m) = arr1(i, 1)
    
15.         End If
    
16.     Next i
    
17.     Range("C1:C" & n) = arr2
    
18. End Sub
    

复制代码

      redim arr3(n)  ，后期赋值从arr(1)开始，arr(0)时始终为空值，join(arr3,",")的结果也始终是以","开头的，这个方法个人认为比较好。
    Range("C1:C" & n) = arr2，这里用m比较好。因为去重后数组的有效个数是m个，Range("C1:C" & m) 可节省对空单元格操作的时间。
     instr方法可以达到去重效果而且通用于文本，但就本例而言，不算是最好的方法。
                                                                                                                                    ----------wcymiss

乐满地

1. 
   
2. Sub 乐满地()
   
3.     Dim arr, brr(1 To 10000, 1 To 1), crr(1 To 10000, 1 To 1)
   
4.     Dim x As Long, k As Long
   
5.     arr = Range("a1:a" & Range("a65536").End(3).Row)
   
6.     For x = 1 To UBound(arr)
   
7.         If brr(arr(x, 1), 1) = "" Then
   
8.             brr(arr(x, 1), 1) = 1
   
9.             k = k + 1
   
10.             crr(k, 1) = arr(x, 1)
    
11.         End If
    
12.     Next
    
13.     Range("b1").Resize(k) = crr
    
14. End Sub

复制代码

上次练习里已经有比=""更快的方法啦！      -------wcymiss

swabe

1. Sub swabe()
   
2.     Dim arr, j&, arr2(1 To 1000), arrtmp(1 To 1000, 1 To 1)
   
3. 
   
4.     arr = Range("A1:A" & Range("A65536").End(xlUp).Row)
   
5.     j = 1
   
6.     For i = 1 To UBound(arr)
   
7.         If IsEmpty(arr2(arr(i, 1))) Then
   
8.             arr2(arr(i, 1)) = 1
   
9.             arrtmp(j, 1) = arr(i, 1)
   
10.             j = j + 1
    
11.         End If
    
12.     Next
    
13.     Range("c1:c1000") = arrtmp
    
14. End Sub

复制代码

请老师指正！

9lee

取巧的办法行吗

1. Dim arr, brr(1 To 1000), crr, i As Long
   
2. arr = Range("a1").CurrentRegion
   
3. For i = 1 To UBound(arr)
   
4.     If i < 1001 Then
   
5.         If brr(i) = "" Then brr(i) = 1001
   
6.     End If
   
7.     brr(arr(i, 1)) = arr(i, 1)
   
8. Next
   
9. crr = Filter(brr, 1001, False)
   
10. [d1].Resize(UBound(crr) + 1) = Application.Transpose(crr)
    
11. End Sub
    

复制代码

9lee

重做：

1. Sub a9lee()
   
2. Dim arr, i As Long
   
3. Dim brr(1 To 1000)
   
4. 
   
5. arr = Range("a1").CurrentRegion
   
6. For i = 1 To UBound(arr)
   
7.     crr = Filter(brr, " " & arr(i, 1) & " ", True)
   
8.     If UBound(crr) < 0 Then x = x + 1: brr(x) = " " & arr(i, 1) & " "
   
9. Next i
   
10. [d1].Resize(x) = Application.Transpose(brr)
    
11. End Sub

复制代码

liuts

1. Sub liuts()
   
2.     Dim t As Double, i%
   
3.     Dim arr, brr(1 To 1000, 1 To 2)
   
4.     t = Timer
   
5.     With Sheet1
   
6.         .Range("d:d").ClearContents
   
7.         arr = Range("A1").CurrentRegion
   
8.         For i = 1 To UBound(arr)
   
9.             If IsEmpty(brr(arr(i, 1), 2)) Then
   
10.                 k = k + 1
    
11.                 brr(k, 1) = arr(i, 1)
    
12.                 brr(arr(i, 1), 2) = i
    
13.             End If
    
14.         Next
    
15.         .Range("d1").Resize(UBound(brr)) = brr
    
16.     End With
    
17.     MsgBox Timer - t
    
18. End Sub

复制代码

我也来个下标的

JLxiangwei

Sub JLxiangwei()
    Dim arr, arr1(1 To 1000), arr2(1 To 1000), x&, y&
    arr = Range("a1:a" & Cells(Rows.Count, 1).End(3).Row)
    For x = 1 To UBound(arr)
        If arr1(arr(x, 1)) = "" Then
            arr1(arr(x, 1)) = 1
            y = y + 1
            arr2(y) = arr(x, 1)
        End If
    Next x
    Range("c1").Resize(y) = Application.Transpose(arr2)
End Sub

happym8888

1. Private Sub Happym8888_Click()
   
2. Dim a() As Variant, c() As String, GuoDu() As Variant
   
3. Dim i As Integer, j As Integer, s As Integer
   
4. s = Range("a65536").End(xlUp).Row
   
5. a = Range("A1:A" & s)
   
6. For i = 1 To s
   
7. For j = i + 1 To s - 1
   
8. If a(j, 1) = a(i, 1) Then
   
9. a(j, 1) = "@"
   
10. End If
    
11. Next j
    
12. Next i
    
13. GuoDu = Application.Transpose(a)
    
14. ricks = Replace(Join(GuoDu(), ","), ",@", "")
    
15. c = Split(ricks, ",")
    
16. Range("D1:D" & UBound(c()) + 1) = Application.Transpose(c())
    
17. End Sub
    

复制代码

兰江自由鱼

1. 
   
2. Option Base 1
   
3. Sub 兰江自由鱼()
   
4.   Dim Arr, Arr_t() As Integer
   
5.   Dim Arr_s(1000) As Integer
   
6.   Dim i As Integer, iNa As Integer, j As Integer
   
7.    j = 1
   
8.   Arr = Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row).Value
   
9.   For i = 1 To UBound(Arr)
   
10.     iNa = Arr(i, 1)
    
11.     If Arr_s(iNa) <> 1 Then
    
12.         ReDim Preserve Arr_t(1 To j)
    
13.         Arr_t(j) = iNa
    
14.         j = j + 1
    
15. '       ReDim Preserve Arr_t(1 To j)
    
16.         Arr_s(iNa) = 1
    
17.      End If
    
18. Next i
    
19. Range("C1").Resize(UBound(Arr_t), 1).Value = Application.Transpose(Arr_t)
    
20. End Sub

复制代码

敬请批改。