Question

所以我有一个非常大的联系人列表，最初是从Outlook导出的，所以它遵循相同的格式。我拥有相当多的重复数据到具有相同名称的记录，但是单独的地址/手机号码。

我正在寻找可以帮助我合并这些副本的宏，这样我就不会丢失同名的不同地址之类的内容。

http://i.stack.imgur.com/EaI6e.png

在这种情况下，我喜欢宏看到A3是A2的副本，所以将J3带到O3并将它们粘贴到Q2中。然后对找到的任何重复对重复此过程。

Answer 1

这有点简陋，但它确实有效。请注意，由于您没有说明在重复次数超过2的情况下会发生什么，如果是这种情况，此宏将无法正常工作。

Sub moveDuplicates()
Dim i As Integer, lastRow As Integer
Dim primaryRange As Range, copyToRange As Range, cel As Range, cel2 As Range, rng As Range
Dim ws      As Worksheet
Set ws = ActiveSheet

'First, sort by "Key" to get duplicates all in a row

With ws.Sort
    .SortFields.Clear
    .SortFields.Add Key:=Range( _
                         "A2:A" & ws.UsedRange.Rows.Count), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
                    xlSortNormal
    .SetRange Range("A1:P" & ws.UsedRange.Rows.Count)
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With


lastRow = ws.UsedRange.Rows.Count
Set rng = ws.Range(ws.Cells(2, 1), ws.Cells(lastRow, 1))

Dim lastDupRow As Integer, startDupRow As Integer, copyRow As Integer

For Each cel In rng
    'First, see if the cell has a duplicate anywhere, if not, then goto next cel
    cel.Select
    If WorksheetFunction.CountIf(rng, cel.Value) > 1 Then
        Debug.Print "Duplicate exists"
        'So, since we know a duplicate exists, we need to copy the duplicate rows' info.
        startDupRow = cel.Row + 1
        lastDupRow = ws.Columns(1).Find(cel.Value, searchDirection:=xlPrevious).Row
        If lastDupRow - startDupRow = 0 Then
            copyRow = lastDupRow
        Else

        End If
        For Each cel2 In ws.Range(Cells(startDupRow, 1), ws.Cells(lastDupRow, 1))
'            pasteRange(cel.Row).Select
'            copyRange(cel2.Row).Select
            pasteRange(cel.Row).Value = copyRange(cel2.Row).Value
            copyRange(cel2.Row).EntireRow.Delete
        Next cel2

    End If
Next cel

End Sub

Private Function copyRange(ByVal iRow As Integer) As Range
    Set copyRange = Range(Cells(iRow, 10), Cells(iRow, 15))
End Function

Private Function pasteRange(ByVal xRow As Integer) As Range
    Set pasteRange = Range(Cells(xRow, 17), Cells(xRow, 22))
End Function

Excel：重复合并

1 个答案: