Excel中：重複合併

所以，我因此它遵循相同的格式得到了一個令人難以置信的大的聯繫人列表，最初是從Outlook導出。我有一個令人難以置信的大量重複記錄，保存着相同名稱的記錄，但地址/手機號碼分開。Excel中：重複合併

我正在尋找一個宏，可以幫助我合併這些重複的，所以我不會失去下的同名文件之類的東西不同的地址。

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

在這種情況下，我很想宏觀地看到，A3是A2的副本，所以採取J3以O3和Q2粘貼這些爲V2。然後對發現的任何重複對重複此過程。

來源

2015-08-18 Henry Carpenter

這很好。祝你好運找到一個。 –

你有什麼嘗試過，接收到什麼錯誤？如果您正在尋找某人爲您編寫宏，請嘗試與軟件開發公司聯繫併爲其付費。 –

是否還有其他字段需要移動，或者字面上只是'J3：O3'。另外，要知道，如果你這樣做，那麼他們的家庭住址實際上會有商戶地址，而沒有任何註釋。 – BruceWayne

這是一個有點簡陋，但它的作品。請注意，由於您沒有說出發生超過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

來源

2015-08-18 17:05:53 BruceWayne

Excel中：重複合併

回答

相關問題