| Private Sub CommandButton1_Click()
Dim 提示信息 Dim 最后行号 Dim 循环计数 Dim 重复数 Dim 筛选列 Dim 升降序 '根据需要设定筛选列 筛选列 = "A" '禁止屏幕刷新 Application.ScreenUpdating = False 提示信息 = MsgBox("先删除不重复的行吗?", 4 + 48 + 256 + 0, "警告:") If 提示信息 = 6 Then '先删除不重复的 最后行号 = Range(筛选列 & "65536").End(xlUp).Row For 循环计数 = 最后行号 To 2 Step -1 '不处理首行的标题栏 重复数 = Application.WorksheetFunction.CountIf(Range(筛选列 & ":" & 筛选列), Range(筛选列 & Format(循环计数))) 'vba中调用Excel内置函数CountIf() If 重复数 = 1 Then Rows(Format(循环计数) & ":" & Format(循环计数)).Delete End If Next 循环计数 End If '再删除重复的(保留1行) 最后行号 = Range(筛选列 & "65536").End(xlUp).Row For 循环计数 = 最后行号 To 2 Step -1 '不处理首行的标题栏 重复数 = Application.WorksheetFunction.CountIf(Range(筛选列 & ":" & 筛选列), Range(筛选列 & Format(循环计数))) 'vba中调用Excel内置函数CountIf() If 重复数 > 1 Then Rows(Format(循环计数) & ":" & Format(循环计数)).Delete End If Next 循环计数 '恢复屏幕刷新 Application.ScreenUpdating = True '将结果排序 最后行号 = Range(筛选列 & "65536").End(xlUp).Row 升降序 = xlAscending '升序:升降序 = xlAscending 降序:升降序 = xlDescending On Error Resume Next Range(筛选列 & 最后行号).Sort Key1:=Range(筛选列 & "2"), Order1:=升降序, Header:=xlGuess, _ OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _ :=xlPinYin If Err <> 0 Then MsgBox "“" & 筛选列 & "”列无法排序!" End Sub
备注:网上一号称“热浪”之高人所发,版权归原作者所有! |