Excel VBA-复制运行按钮/添加位置 [英] Excel VBA-Duplicates run with button/add location

问题描述

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

1。）这个代码只能在我点击一个按钮时运行。

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

  Sub Worksheet_Change（ByVal Target As Excel.Range）
 Dim C As Range ，我As Long 
如果不相交（目标，我[A：A]）没有，然后
 Application.EnableEvents = False 
对于每个C在目标
如果C. Column = 1和C.Value> 然后
如果WorksheetFunction.CountIf（Me。[A：A]，C.Value）> 1然后
i = C.Interior.ColorIndex 
f = C.Font.ColorIndex 
 C.Interior.ColorIndex = 3'Red 
 C.Font.ColorIndex = 6'黄色
 C.Select 
 MsgBoxDuplicate Entry！，vbCritical，Error
 C.Interior.ColorIndex = i 
 C.Font.ColorIndex = f 
 End If 
结束如果
下一个
 Application.EnableEvents = True 
如果
 End Sub 
  

如果您帮助我，我真的很感激。

解决方案

添加代码到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 
 
设置MyData = Range（A1：A&单元格（Rows.Count，A）。End（xlUp）.Row）
设置MyUniqueList = CreateObject（Scripting.Dictionary）
 
 Application.ScreenUpdating = False 
 MyDupList =：intMyCounter = 0 
'//查找重复
对于MyData中的每个RangeCell 
如果RangeCell<> V和RangeCell R然后
如果评估（COUNTIF（& MyData.Address&，& RangeCell.Address&））> 1然后
'//颜色。更改适合RGB（141，180，226）。 
 RangeCell.Interior.Color = RGB（141，255，226）
如果MyUniqueList.exists（CStr（RangeCell））= False然后
 intMyCounter = intMyCounter + 1 
 MyUniqueList。添加CStr（RangeCell），intMyCounter 
如果MyDupList =然后
 MyDupList = RangeCell 
 Else 
 MyDupList = MyDupList& vbNewLine& RangeCell 
 End If 
 End If 
 Else 
 RangeCell.Interior.ColorIndex = xlNone 
 End If 
 End If 
 Next RangeCell 
'//将重复从列1移动到列7 =（G：G）
 lngWriteRow = 1 
 lngLastRow = Cells（Rows.Count，1）.End（xlUp）.Row 
对于lngLoopRow = lngLastRow到1步-1 
带单元格（lngLoopRow，1）
如果WorksheetFunction.CountIf（Range（A1：A& lngLastRow），.Value）> 1然后
如果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 
 
如果MyDupList<> 然后
 MsgBox找到重复的条目：& vbNewLine& MyDupList 
 Else 
 MsgBox在& MyData.Address 
 End If 
 End Sub 
  

。

 添加模块
  

 添加按钮
  

 分配给宏
  

I am new to Excel VBA and I really need your help. I have a code that will look for the duplicate values in Column A. This code will highlight the duplicate values. I want:

1.) This code to ONLY run when I click on a button.

2.) I would like to have (somewhere in the same worksheet), the number of duplicate results and a hyper link that when you click on it will direct you the duplicate result (this is because I have sometimes huge files that I need to validate). Here is the code I currently have:

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

I would really appreciate it if you help me with this.

解决方案

Add the code to 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

这篇关于Excel VBA-复制运行按钮/添加位置的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！