【字典与数组二期1班】第一讲作业数组去重（选做）【已开贴】
本帖最后由 liuguansky 于 2011-12-23 21:56 编辑代码直接在回帖用贴出，不需再上传附件。
过程名请使用id名。（数字开头的id请前面加字母a）
非上交作业请勿回帖，谢谢。
要求中所指的“工作表函数”，不包括最后用于转置数组到工作表的Transpose。特此说明 本帖最后由 那么的帅 于 2011-12-17 19:10 编辑
Sub 那么的帅1()
Dim Arr1, Arr2(1 To 1000), Arr11()
Dim Row1 As Long, I As Long, M As Long
With Sheets("Sheet1")
Row1 = .Range("A" & .Rows.Count).End(xlUp).Row
Arr1 = .Range("A1:A" & Row1)
For I = 1 To UBound(Arr1)
If Arr2(Arr1(I, 1)) <> 1 Then
M = M + 1
ReDim Preserve Arr11(1 To 1, 1 To M)
Arr11(1, M) = Arr1(I, 1)
Arr2(Arr1(I, 1)) = 1
End If
Next I
.Range("C1:C" & .Rows.Count).ClearContents
.Range("C1").Resize(M, 1) = Application.Transpose(Arr11)
End With
End Sub
Sub 那么的帅2()
Dim Arr1, Arr2(1 To 1000), Arr11(1 To 1000, 1 To 1)
Dim Row1 As Long, I As Long, M As Long
With Sheets("Sheet1")
Row1 = .Range("A" & .Rows.Count).End(xlUp).Row
Arr1 = .Range("A1:A" & Row1)
For I = 1 To UBound(Arr1)
If Arr2(Arr1(I, 1)) <> 1 Then
M = M + 1
Arr11(M, 1) = Arr1(I, 1)
Arr2(Arr1(I, 1)) = 1
End If
Next I
.Range("D1:D" & .Rows.Count).ClearContents
.Range("D1").Resize(M, 1) = Arr11
End With
End Sub
Sub Benol()
Dim src, cnt&
src = Range(, Cells(.End(3).Row, 1))
For i = 1 To UBound(src)
If Application.Match(src(i, 1), src, False) = i Then
cnt = cnt + 1
src(cnt, 1) = src(i, 1)
End If
Next
Columns(3).ClearContents
.Resize(cnt) = src
End Sub Sub Benol()
Dim src, cnt&, intArr(1 To 1000)
src = Range(, Cells(.End(3).Row, 1))
For i = 1 To UBound(src)
If IsEmpty(intArr(src(i, 1))) Then
cnt = cnt + 1
src(cnt, 1) = src(i, 1)
intArr(src(i, 1)) = 1
End If
Next
Columns(3).ClearContents
.Resize(cnt) = src
End Sub 本帖最后由 wcymiss 于 2011-12-19 12:20 编辑
吴姐辛苦了！{:1612:}
方法1比较通用，不过速度不容乐观；方法2取了点巧，应该可以吧！{:3212:}
方法1：
Sub windimi007_1()
Dim arr, arr1()
Dim i&, j&
On Error Resume Next
arr = Range("A1").CurrentRegion
For i = 1 To UBound(arr)
If UBound(Filter(Split("|" & Join(arr1, "|,|") & "|", ","), "|" & arr(i, 1) & "|", True)) Then
j = j + 1
ReDim Preserve arr1(1 To j)
arr1(j) = arr(i, 1)
End If
Next i
Erase arr
Range("C1").Resize(UBound(arr1)) = WorksheetFunction.Transpose(arr1)
Erase arr1
End Sub方法2：
Sub windimi007_2()
Dim arr, arr1(), arr2()
Dim i&, j&
On Error Resume Next
arr = Range("A1").CurrentRegion
For i = 1 To UBound(arr)
If UBound(Filter(arr1, arr(i, 1) + 1000, True)) Then
j = j + 1
ReDim Preserve arr1(1 To j)
ReDim Preserve arr2(1 To j)
arr1(j) = arr(i, 1) + 1000
arr2(j) = arr(i, 1)
End If
Next i
Erase arr
Erase arr1
Range("C1").Resize(UBound(arr2)) = WorksheetFunction.Transpose(arr2)
Erase arr2
End Sub
第一种方法比较慢，但通用性较好。第二种稍快，利用了题目的已知条件：数据是1-1000以内的整数。但根据这个条件还有更好的方法。
不建议在作业题里用“on error resume next。因为作业本身就是要发现问题、解决问题。容错语句把错误都掩埋了。
本楼不评分，在下一楼一起评。
--------wcymiss
本帖最后由 wcymiss 于 2011-12-19 12:24 编辑
似乎下面的代码会更快点吧！临睡前想到的，还没来得及测试速度。{:3212:}
Sub windimi007_3()
Dim arr, arr1(1 To 1000), arr2(1 To 1000)
Dim i&, j&
On Error Resume Next
arr = Range("A1").CurrentRegion
For i = 1 To UBound(arr)
If UBound(Filter(arr1, arr(i, 1) + 1000, True)) Then
j = j + 1
arr1(j) = arr(i, 1) + 1000
arr2(j) = arr(i, 1)
End If
Next i
Erase arr
Erase arr1
Range("C1").Resize(UBound(arr2)) = WorksheetFunction.Transpose(arr2)
Erase arr2
End Sub
加1000后Filter是一种不错的思路。不过还是没有instr快。------wcymiss
本帖最后由 wcymiss 于 2011-12-19 20:54 编辑
Sub liuts()
Dim t
t = Timer
Dim arr, crr(), i%, k%
arr = Range("a1").CurrentRegion
ReDim Preserve crr(1 To 1): crr(1) = arr(1, 1): k = 1
For i = 2 To UBound(arr)
If InStr("," & Join(crr, ",") & ",", "," & arr(i, 1) & ",") = 0 Then
k = k + 1
ReDim Preserve crr(1 To k)
crr(k) = arr(i, 1)
End If
Next
Range("d1").Resize(UBound(crr)) = Application.Transpose(crr)
MsgBox Timer - t
End Sub
instr去重的方法比较通用，速度也比filter快，但针对本题有更好的方法。 -------wcymiss
本楼不评分了，集中在18楼评分。
Option Base 1
Private Sub qushui()
Dim a, b(1000) As Integer, c(1000, 1) As Integer
Dim m&, k%
m = .End(xlUp).Row
a = Range("a1:a" & m)
For i = 1 To m
If b(a(i, 1)) = 0 Then
b(a(i, 1)) = a(i, 1)
k = k + 1
c(k, 1) = b(a(i, 1))
End If
Next
.Resize(k, 1) = c
End Sub
Sub rxj_0414()
Dim N As Long, i As Integer, cnt As Integer
Dim arr, arr1000(1 To 1000), arr2()
N = Sheet1..End(xlUp).Row
arr = Application.Transpose(Sheet1.Range("A1:A" & N))
cnt = 1
For i = 1 To N
If arr1000(arr(i)) <> 1 Then
arr1000(arr(i)) = 1
ReDim Preserve arr2(1 To cnt)
arr2(cnt) = arr(i)
cnt = cnt + 1
End If
Next i
Sheet1.Range("C1:C" & UBound(arr2)) = Application.Transpose(arr2)
End Sub
Sub csmctjg()
Dim arr, arr1() As Integer, i&, j&, k&
arr = Range("A1:A" & .End(xlUp).Row)
k = k + 1
ReDim arr1(1 To k)
arr1(1) = arr(1, 1)
For i = 2 To UBound(arr)
For j = 1 To UBound(arr1)
If arr(i, 1) = arr1(j) Then GoTo 100
Next j
k = k + 1
ReDim Preserve arr1(1 To k)
arr1(k) = arr(i, 1)
100:
Next i
.Resize(k) = Application.Transpose(arr1)
End Sub