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

wcymiss · 发表于 2011-12-17 16:50

本帖最后由 liuguansky 于 2011-12-23 21:56 编辑

QQ截图未命名.png

【课时一作业2】数组去重.rar (70.26 KB, 下载次数: 248)

那么的帅 · 发表于 2011-12-17 17:22

本帖最后由那么的帅于 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

复制代码

Benol · 发表于 2011-12-17 18:21

Sub Benol()
Dim src, cnt&
src = Range([A1], Cells([A65536].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
[C1].Resize(cnt) = src
End Sub

复制代码

Benol · 发表于 2011-12-17 19:25

Sub Benol()
Dim src, cnt&, intArr(1 To 1000)
src = Range([A1], Cells([A65536].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
[C1].Resize(cnt) = src
End Sub

复制代码

windimi007 · 发表于 2011-12-17 22:05

本帖最后由 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

windimi007 · 发表于 2011-12-17 23:05

本帖最后由 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

liuts · 发表于 2011-12-18 12:45

本帖最后由 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楼评分。

qushui · 发表于 2011-12-18 14:49

Option Base 1
Private Sub qushui()
Dim a, b(1000) As Integer, c(1000, 1) As Integer
Dim m&, k%
m = [a65536].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
[d1].Resize(k, 1) = c
End Sub

复制代码

rxj_0414 · 发表于 2011-12-18 19:08

Sub rxj_0414()
Dim N As Long, i As Integer, cnt As Integer
Dim arr, arr1000(1 To 1000), arr2()
N = Sheet1.[A65536].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

复制代码

csmctjg · 发表于 2011-12-18 19:59

Sub csmctjg()
Dim arr, arr1() As Integer, i&, j&, k&
arr = Range("A1:A" & [A65536].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
[C1].Resize(k) = Application.Transpose(arr1)
End Sub

复制代码

		自动登录	找回密码
密码			注册

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

评分

点评

评分

点评

评分

评分

评分

评分

评分

点评