从RemoveDuplicates获取信息

我在列K中有一个简短的值列表。 如果使用Ribbon命令删除重复项，Excel将删除重复项并输出一条消息，指出删除重复项的数量：

如果我使用VBA来做同样的事情：

Sub Macro1() Columns("K:K").Cells.RemoveDuplicates Columns:=1, Header:=xlYes End Sub 

重复被删除，但消息从不出现。

如果我使用macros，我如何得到消息？

Answer 1

MsgBox不允许大量的自定义空间，但是设置一个UserForm看起来就像Remove Duplicates对话框一样，你必须要做的事情，所以MsgBox将不得不这样做。

 Option Explicit Sub RemoveDuplicatesWithReport() Dim unique() As Variant Dim ws As Worksheet Dim x As Long, uidCt As Long, dCol As Long, remCt As Long On Error GoTo ErrorHandler 'turn off screenupdating/calculation Application.ScreenUpdating = False Application.Calculation = xlCalculationManual 'current sheet Set ws = ActiveSheet 'column K dCol = 11 'resize array for counting uniques ReDim unique(ws.Cells(ws.Rows.Count, dCol).End(xlUp).Row) 'count how many unique values there are (uidCt) For x = 2 To ws.Cells(ws.Rows.Count, dCol).End(xlUp).Row If CountIfArray(ws.Cells(x, dCol), unique()) = 0 Then unique(uidCt) = ws.Cells(x, dCol).Text uidCt = uidCt + 1 End If Next x 'count before removal remCt = WorksheetFunction.CountA(ws.Columns(dCol)) - 1 'remove duplicates ws.Columns(dCol).RemoveDuplicates Columns:=1, Header:=xlYes 'count after removal remCt = remCt - (WorksheetFunction.CountA(ws.Columns(dCol)) - 1) 'turn screenupdating/calculation back on Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic ws.Calculate 'display results MsgBox remCt & " duplicate values were found and removed." & vbCr & uidCt & " unique values remain.", vbInformation, "Remove Duplicates" Exit Sub ErrorHandler: Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic MsgBox Err.Number & vbCr & Err.Description Exit Sub End Sub Public Function CountIfArray(lookup_value, lookup_array) CountIfArray = Application.Count(Application.Match(lookup_value, lookup_array, 0)) End Function