Excel VBA-Duplicatesbutton/添加位置运行

我是新的Excel VBA，我真的需要你的帮助。 我有一个代码，将在列A中查找重复值。此代码将突出显示重复的值。 我想要：

1）这个代码只有当我点击一个button时才能运行。

2.）我想有（在同一工作表中的某个地方），重复结果的数量和超链接，当你点击它会指导你重复的结果（这是因为我有时有巨大的文件，我需要validation）。 这是我现在的代码：

Sub Worksheet_Change(ByVal Target As Excel.Range) Dim C As Range, i As Long If Not Intersect(Target, Me.[A:A]) Is Nothing Then Application.EnableEvents = False For Each C In Target If C.Column = 1 And C.Value > "" Then If WorksheetFunction.CountIf(Me.[A:A], C.Value) > 1 Then i = C.Interior.ColorIndex f = C.Font.ColorIndex C.Interior.ColorIndex = 3 ' Red C.Font.ColorIndex = 6 ' Yellow C.Select MsgBox "Duplicate Entry !", vbCritical, "Error" C.Interior.ColorIndex = i C.Font.ColorIndex = f End If End If Next Application.EnableEvents = True End If End Sub 

我真的很感激，如果你帮我这个。

Answer 1

将代码添加到Module1 Alt + F11

 Option Explicit Sub MyButton() Dim RangeCell As Range, _ MyData As Range Dim MyDupList As String Dim intMyCounter As Integer Dim MyUniqueList As Object Dim lngLastRow As Long, lngLoopRow As Long Dim lngWriteRow As Long Set MyData = Range("A1:A" & Cells(Rows.Count, "A").End(xlUp).Row) Set MyUniqueList = CreateObject("Scripting.Dictionary") Application.ScreenUpdating = False MyDupList = "": intMyCounter = 0 '// Find Duplicate For Each RangeCell In MyData If RangeCell <> "V" And RangeCell <> "R" Then If Evaluate("COUNTIF(" & MyData.Address & "," & RangeCell.Address & ")") > 1 Then '// Color. Change to suit RGB(141, 180, 226). RangeCell.Interior.Color = RGB(141, 255, 226) If MyUniqueList.exists(CStr(RangeCell)) = False Then intMyCounter = intMyCounter + 1 MyUniqueList.Add CStr(RangeCell), intMyCounter If MyDupList = "" Then MyDupList = RangeCell Else MyDupList = MyDupList & vbNewLine & RangeCell End If End If Else RangeCell.Interior.ColorIndex = xlNone End If End If Next RangeCell '// Move duplicate from Column 1 to Column 7 = (G:G) lngWriteRow = 1 lngLastRow = Cells(Rows.Count, 1).End(xlUp).Row For lngLoopRow = lngLastRow To 1 Step -1 With Cells(lngLoopRow, 1) If WorksheetFunction.CountIf(Range("A1:A" & lngLastRow), .Value) > 1 Then If Range("G:G").Find(.Value, lookat:=xlWhole) Is Nothing Then Cells(lngWriteRow, 7) = .Value lngWriteRow = lngWriteRow + 1 End If End If End With Next lngLoopRow Set MyData = Nothing: Set MyUniqueList = Nothing Application.ScreenUpdating = False If MyDupList <> "" Then MsgBox "Duplicate entries have been found:" & vbNewLine & MyDupList Else MsgBox "There were no duplicates found in " & MyData.Address End If End Sub 

。

 Add Module 

 Add Button 

 Assign to Macro