Excel VBA поиск дубликатов, размещение соответствующих строк и значения поиска - PullRequest
Новая
       7

Excel VBA поиск дубликатов, размещение соответствующих строк и значения поиска

0 голосов
/ 24 октября 2018

Я работаю со списком информации о клиентах, ищу дубликаты и вставляю всю строку в другой лист.Мой текущий код найдет дубликаты и вставит их, однако он не вставит строку, используемую для критериев поиска.

Example

Когда я запускаю свой кодстрока 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

Ответы [ 2 ]

0 голосов
/ 05 ноября 2018

Если я понял ваш вопрос, у меня есть альтернативный код: 

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

Я попробовал код и работает нормально.

Надеюсь, это поможет.

0 голосов
/ 24 октября 2018

Я бы не стал использовать циклы, подобные описанным выше, но лучше использовать 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

Находясь в представлении / макросах, в верхней строке меню, где отображается окно редактирования файла ...

Нажмите TOOLS, а затем нажмите Ссылки

Прокрутите вниз до объектов данных Microsoft ActiveX и выберите последний с галочкой

... Измените эту строку с новыми подписками на (0)(1) (2)

Ячейки (nRow, "A") = rs.Fields (0): Ячейки (nRow, "B") = rs.Fields (1): Ячейки (nRow, "C") = rs.Fields (2)

...