Excel VBA-重複運行按鈕/添加位置

Question

我是新的Excel VBA，我真的需要你的幫助。我有一個代碼將在列A中查找重複值。此代碼將突出顯示重複值。我想要：

1）這個代碼只有當我點擊一個按鈕時纔會運行。

2.）我想有（在同一個工作表中的某個地方），重複結果的數量和一個超鏈接，當你點擊它時將指導你重複的結果（這是因爲我有時有巨大的文件我需要驗證）。這裏是我目前的代碼：

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

的代碼添加到Module 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