Question : macro to merge duplicate data

Hi Experts

Please help with a macro that reads through a long report in excel, extracted from another application.

This sheet has more than 20000 records with lot of duplicates

Attached is the Sample data for reference.

Thanks

PS : already checked solution posted by
http://www.experts-exchange.com/Software/Office_Productivity/Office_Suites/MS_Office/Excel/Q_21900413.html?sfQueryTermInfo=1+data+duplic+excel+merg

this does not merge all information.

Answer : macro to merge duplicate data

Hi There,
Can you try this code now? This is set to check for a match between the first and the last names.

- Ardhendu.

                       
         
           
             1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:

           
           
             Option Explicit
Sub MergeDups()
 
Dim rngX As Range
Dim i As Integer
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ctr1 As Integer
Dim lstrow As Integer
Dim j As Integer
 
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set ws1 = Sheets("input")
ws1.Range("A1:Q" & Cells(65536, "A").End(xlUp).Row).Sort Key1:=Range("B1"), Order1:=xlAscending, Key2:=Range("C1"), _
Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortNormal
 
On Error Resume Next
Sheets("output").Delete
Sheets.Add
Set ws2 = ActiveSheet
ws2.Name = "Output"
ws1.Rows("1:1").Copy
ws2.Rows("1:1").PasteSpecial
Application.CutCopyMode = False
ctr1 = 0
 
ws1.Select
For i = 2 To ws1.Cells(65536, "B").End(xlUp).Row
    If Trim(UCase(ws1.Range("B" & i))) = Trim(UCase(ws1.Range("B" & i + 1))) _
    And Trim(UCase(ws1.Range("C" & i))) = Trim(UCase(ws1.Range("C" & i + 1))) Then
        ws1.Rows(i & ":" & i).Copy
        lstrow = ws2.Cells(65536, "B").End(xlUp).Row + 1
        ws2.Range(lstrow & ":" & lstrow).PasteSpecial
        Application.CutCopyMode = False
        For j = 1 To 17
            If ws1.Cells(i, j) = "" And ws1.Cells(i, j) <> ws1.Cells(i + 1, j) Then
                ws1.Cells(i + 1, j).Copy
                ws2.Cells(lstrow, j).PasteSpecial
            End If
        Next j
        i = i + 1
        ctr1 = ctr1 + 1
    Else
        If Trim(UCase(ws1.Range("B" & i - 1))) = Trim(UCase(ws1.Range("B" & i))) _
         And Trim(UCase(ws1.Range("C" & i - 1))) = Trim(UCase(ws1.Range("C" & i))) Then
        
            i = i + 1
            ws1.Rows(i & ":" & i).Copy
            lstrow = ws2.Cells(65536, "B").End(xlUp).Row + 1
            ws2.Range(lstrow & ":" & lstrow).PasteSpecial
            Application.CutCopyMode = False
        Else
            ws1.Rows(i & ":" & i).Copy
            lstrow = ws2.Cells(65536, "B").End(xlUp).Row + 1
            ws2.Range(lstrow & ":" & lstrow).PasteSpecial
            Application.CutCopyMode = False
        End If
    End If
Next i
ws2.Select
ws2.Range("A1").Select
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox ("Done! Merging of data completed. " & ctr1 & " duplicate records found and merged")
End Sub
           
         

Open in New Window Select All