Excel VBA 查找重复项、发布匹配行和搜索值

Question

我正在使用客户信息列表搜索重复项，然后将整行粘贴到不同的工作表中。我当前的代码会找到重复项并粘贴它们，但它不会粘贴用于搜索条件的行。

当我运行我的代码时，它会将第 3 行复制到不同的页面，但是我需要它也复制第 1 行，以便能够看到同一“电话”下列出的所有“姓名”，而不仅仅是重复的。

这是我当前的代码：

Option Explicit
Dim output As Worksheet
Dim data As Worksheet
Dim hold As Object
Dim celli
Dim nextRow

Sub main()
    Set output = Worksheets("phoneFlags")
    Set data = Worksheets("filteredData")
    Set hold = CreateObject("Scripting.Dictionary")

    For Each celli In data.Columns(3).Cells
        If Not hold.Exists(CStr(celli.Value)) Then
            If Not IsEmpty(celli.Value) Then
                hold.Add Key:="" & celli.Value, Item:=celli.Row
            End If
        ElseIf hold.Exists(CStr(celli.Value)) Then
            'Copies row to sheet
            data.Rows(celli.Row).Copy (output.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0))
        End If
    Next celli
End Sub

我尝试创建第二个For Each 循环，但返回的结果相同。

        ElseIf hold.Exists(CStr(celli.Value)) Then
        match = celli.Value
            For Each match In data.Columns(3).Cells
                data.Rows(celli.Row).Copy (output.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0))
            Next match
        End If

Answer 1

我会避免像上面这样的循环，而是使用 SQL

Option Explicit

Sub SQL()
    ' from https://stackoverflow.com/questions/19755396/performing-sql-queries-on-an-excel-table-within-a-workbook-with-vba-macro
    ' by Joan-Diego Rodriguez

    ' get where we are and setup strings
    Dim strFile As String, strCon As String
    strFile = ThisWorkbook.FullName
    strCon = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strFile _
        & ";Extended Properties=""Excel 12.0;HDR=Yes;IMEX=1"";"

    ' set up for ADO
    Dim cn As ADODB.Connection, rs As ADODB.Recordset, strSQL As String
    Set cn = CreateObject("ADODB.Connection")
    Set rs = CreateObject("ADODB.Recordset")
    cn.Open strCon

    ' create SQL and open it
    strSQL = ""
    strSQL = strSQL & "SELECT * FROM [filteredData$] "
    strSQL = strSQL & "  Where PhoneNum In "
    strSQL = strSQL & "    (Select PhoneNum FROM [filteredData$] "
    strSQL = strSQL & "      Group By PhoneNum "
    strSQL = strSQL & "      Having Count(*) > 1"
    strSQL = strSQL & "     )"
    strSQL = strSQL & "   "   ' maybe have an order by here

    rs.Open strSQL, cn
    'Debug.Print rs.Name, rs.PhoneNum

    Dim nRow As Long
    nRow = 1
    Worksheets("phoneFlags").Activate
    Cells(nRow, "A") = "Name": Cells(nRow, "B") = "PhoneNum": Cells(nRow, "C") = "EMail"
    Do While Not rs.EOF
        nRow = nRow + 1
            Cells(nRow, "A") = rs.Fields(0): Cells(nRow, "B") = rs.Fields(1): Cells(nRow, "C") = rs.Fields(2)
        rs.movenext
    Loop

End Sub

在视图/宏中，在您的顶部菜单栏上，文件编辑视图...

按工具，然后按参考文献

向下滚动到 Microsoft ActiveX 数据对象，然后选择带有复选标记的最后一个

... 将具有新下标的这一行更改为 (0) (1) (2)

Cells(nRow, "A") = rs.Fields(0): Cells(nRow, "B") = rs.Fields(1): Cells(nRow, "C") = rs.Fields(2)

Answer 2

如果我理解你的问题，我有一个替代代码：

Sub test()
'control duplicate phone number. Execute macro in sheet1(active)

Dim rows, j, i, c, k As Integer
Dim swap As Variant

'in sheet where are all the data count number rows
rows = ThisWorkbook.Worksheets("Sheet1").Range("A:A").Cells.SpecialCells(xlCellTypeConstants).Count

c = 1 ' count rows number of the second sheet
For j = 1 To rows
    swap = Cells(j, 2) 'control the phone number
    For i = 1 To rows

        If (Cells(i, 2) = swap And i <> j) Then ' if find duplicate copy data into 2° sheet

            With Sheets("Sheet2")
                .Cells(c, 1) = Cells(j, 1) 'copy name
                .Cells(c, 2) = Cells(j, 2) 'copy phone number
                .Cells(c, 3) = Cells(j, 3) ' copy mail
                c = c + 1 'increment row of the second sheet
                i = rows 
            End With
        End If
    Next i
Next j
End Sub

我尝试了代码并且工作正常。

希望这会有所帮助。