|
44、筛选多列不重复值到新表的a列，Collection集合的应用。
BKcEHABM.rar
(14.03 KB, 下载次数: 243)
代码：
Private Sub CommandButton1_Click() '把选中列的不重复值，转到新表里的a列
Dim i&, irow&, k&, Imax% '&是Long长整型的缩写，%为整型的缩写
Dim M&
Dim rng As Range, c As Range
Dim arr, arr1() '定义两个数组，arr为取单元格的值的数组
Dim h As New Collection '定义h为一个新的集合
Application.ScreenUpdating = False '关闭屏幕更新，防止闪屏和加快代码运行
Set rng = Selection '设置当前选择的区域为一变量rng
Imax = Cells.SpecialCells(xlCellTypeLastCell).Column 'imax为当前工作表的最后一个单元格的列，即最后一列
On Error Resume Next '出现错误的时候，程序执行下一句，处理collection集合在add重复值时产生错误的请看
For i = 1 To Imax '从第一列到最后一列
Set c = Application.Intersect(rng, Columns(i)) '设置c为本列与选择的区域的交集
If Not c Is Nothing Then '如果这个交集存在的话
irow = Cells(65536, i).End(xlUp).Row '当前列的最后一非空行
arr = Range(Cells(1, i), Cells(irow, i)) '把本列的第一行到第irow行赋值给数组
For k = 1 To irow '在这个数组里作一个循环
If arr(k, 1) <> "" Then '如果它不等于空的时候
h.Add arr(k, 1), CStr(arr(k, 1)) '增加到集合里去
End If
Next k
End If
Next i
Err.Clear '清除原先的错误参数，之后的代码如果产生错误的时候会报错
On Error GoTo 0
M = h.Count '集合的最大个数
If M = 0 Then Exit Sub
ReDim arr1(1 To M, 0) '定义一个数组，等于集合的所有格式
For i = 1 To M
arr1(i, 0) = h(i) '把集合赋值给数组arr1
Next
With Sheet1.[a1]
.EntireColumn.ClearContents '清除A1整列的数据
.Resize(M, 1).Value = arr1 '给单元格赋值，等于arr1数组
.Parent.Select '工作表sheet1选择
.CurrentRegion.Sort Key1:=.Cells(1), Order1:=xlAscending, Header:=xlNo 'a1的当前区域按升序排序
.Select 'a1选择
End With
Application.ScreenUpdating = True '还原系统设置
End Sub
| 
楼主: Long_III
[复制链接]
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2005-9-13 20:12
楼主
