Merge Duplicates Rows + Keep Unique Cells intact

XcelGrub

New Member
Joined
Jun 10, 2015
Messages
8
I have been currently working on a problem for the last few days, using a number of resources throughout this fantastic site and others - mixing and merging code to try and achieve (what I think is a unique problem) but have not quite landed successfully on a solution.

I currently take output in the form of a .csv (varying length of rows) however the columns (and their order) remain constant - this .csv will then run through a macro (just been converting the .csv to .xlsm and adding a module in) to produce the desired result. Currently I have 50 columns, of which the a number of rows are duplicates with only the end columns changing - what I would like to do is merge the duplicate rows, but keep the unique cells (and where I am falling flat - is they keep their format and location).

Now that I've successfully confused you all haha - here's a visual aid :).

Current:

Zw5wdD9.jpg


Desired:

wVqmxOv.jpg



Hopefully the above makes sense - everything I've come across/found/tried has resulted in the duplicates being merged fine but the unique values all being merged with commas, spaces and so on - I need the unique values to keep their line format so they can be read correctly. If they are all merged into the same cell and separated with comma or alike, it becomes very hard to make sense.

Some code that may assist that I've tried piecing together:

Merges Rows based on specifics - separator for non-duplicates is vblf - this is quite close but doesn't keep formatting/lines (credit: Tony Dallimore)

Code:
Sub MergeRows()

  ' Merges adjacent rows for which all columns listed in ColMatch are equal
  ' by appending the contents of the other columns from the second row to
  ' the first row and then deleting the second row.


  Dim CheckOK As Boolean
  Dim ColCrnt As Long
  Dim ColLast As Long
  Dim ColMatch() As Variant
  Dim ColMerge() As Variant
  Dim InxMatch As Long
  Dim InxMerge As Long
  Dim RowCrnt As Long
  Dim RowLast As Long
  Dim RowsMatch As Boolean
  Dim TimeStart As Single


  ' Defines the first row to be considered for merging.  This avoids
  ' looking at header rows (not very important) and allows a restart
  ' from row 600 or whatever (might be important).
  Const rowDataFirst As Long = 2


  ' Defines the string to be placed between the value in the first row
  ' and the value from the second row.
  Const Separator As String = vbLf


 ' Speeds up processing
  Application.ScreenUpdating = False


  ' Stops the code from being interrupted by event routines
  Application.EnableEvents = False


  ' Use status bar as a progress indicator
  Application.DisplayStatusBar = True


  ' Record seconds since midnight at start of routine.
  TimeStart = Timer


  ' Defines the columns which must have the same values in two
  ' adjacent rows for the second row to be merged into the
  ' first row.  Column numbers must be in ascending order.
  ColMatch = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21)


  ' Defines the columns for which values from the second row
  ' are to be appended to the first row of a matching pair.
  ' Column numbers must be in ascending order.  ColMatch and
  ' ColMerge together must specify every used column.
  ColMerge = Array(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)


  ' Replace "Merge" with the name of your worksheet
  With Worksheets("Sheet1")


    ' Find last used column and last used row
    ColLast = .Cells.Find("*", .Range("A1"), xlFormulas, xlWhole, _
                                         xlByColumns, xlPrevious).Column
    RowLast = .Cells.Find("*", .Range("A1"), xlFormulas, xlWhole, _
                                         xlByRows, xlPrevious).Row


    ' Validate column parameters.  Every column must be specified once
    ' in either ColMatch or ColMerge.
    InxMatch = 0        ' 0 = lower bound of array
    InxMerge = 0
    For ColCrnt = 1 To ColLast
      CheckOK = False   ' Set true if check successful
      If InxMatch > UBound(ColMatch) Then
        ' ColMatch array exhausted
      Else
        If ColCrnt = ColMatch(InxMatch) Then
          CheckOK = True
          InxMatch = InxMatch + 1
        End If
      End If
      If Not CheckOK Then
        If InxMerge > UBound(ColMerge) Then
          ' ColMerge array exhausted
        Else
          If ColCrnt = ColMerge(InxMerge) Then
            CheckOK = True
            InxMerge = InxMerge + 1
          End If
        End If
      End If
      If Not CheckOK Then
        Call MsgBox("I was unable to find column " & ColCrnt & " in either" & _
                    " ColMatch or ColMerge.  Please correct and try again.", _
                                                                       vbOKOnly)
        Exit Sub
      End If
    Next


    RowCrnt = rowDataFirst
    Do While True


      If RowCrnt Mod 100 = 0 Then
        ' Use status bar to indicate progress
        Application.StatusBar = "Row " & RowCrnt & " of " & RowLast
      End If


      ' Attempt to match RowCrnt and RowCrnt+1
      RowsMatch = True    ' Assume match until find otherwise
      For InxMatch = 0 To UBound(ColMatch)
        ColCrnt = ColMatch(InxMatch)
        If .Cells(RowCrnt, ColCrnt).Value <> _
           .Cells(RowCrnt + 1, ColCrnt).Value Then
          ' Rows do not match
          RowsMatch = False
          Exit For
        End If
      Next


      If RowsMatch Then
        ' Rows match.  Merge second into first.
        For InxMerge = 0 To UBound(ColMerge)
          ColCrnt = ColMerge(InxMerge)
          .Cells(RowCrnt, ColCrnt).Value = .Cells(RowCrnt, ColCrnt).Value & _
                                           Separator & _
                                           .Cells(RowCrnt + 1, ColCrnt).Value
        Next
        ' Second row merged into first.  Discard second row.
        .Rows(RowCrnt + 1).EntireRow.Delete
        ' RowLast has moved up.
        RowLast = RowLast - 1
        ' Do not step RowCrnt because there may be another match for it
        If RowCrnt = RowLast Then
          ' All rows checked.
          Exit Do
        End If
      Else
        ' Rows do not match.  RowCrnt no longer of interest.
        RowCrnt = RowCrnt + 1
        If RowCrnt = RowLast Then
          ' All rows checked.
          Exit Do
        End If
      End If
    Loop
  End With


  ' Output duration of macro to Immediate window
  Debug.Print Format(Timer - TimeStart, "#,##0.00")


  Application.StatusBar = False
  Application.EnableEvents = True
  Application.ScreenUpdating = True


End Sub

Simply merges rows based on A2 range - I've tried fiddling with this to sort on A2:* range but no luck:

Code:
Sub test()    
    Dim a, i As Long, ii As Long, n As Long, z As String, x As Long
    a = Sheets("Sheet1").Range("a2").CurrentRegion.Value
    n = 1
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        For i = 2 To UBound(a, 1)
            For ii = 2 To 11
                z = z & Chr(2) & a(i, ii)
            Next
            If Not .exists(z) Then
                n = n + 1: .Item(z) = n
                For ii = 1 To UBound(a, 2)
                    a(n, ii) = a(i, ii)
                Next
            Else
                x = .Item(z)
                For ii = 12 To UBound(a, 2)
                    If a(i, ii) <> "" Then
                        a(x, ii) = a(x, ii) & IIf(a(x, ii) <> "", ",", "") & a(i, ii)
                    End If
                Next
            End If
            z = ""
        Next
    End With
    On Error Resume Next
    Application.DisplayAlerts = False
    Sheets("result").Delete
    On Error GoTo 0
    Sheets.Add().Name = "Result"
    With Sheets("result").Cells(1).Resize(n, UBound(a, 2))
        .Value = a
        .EntireColumn.AutoFit
    End With
End Sub

Thanks so much!

-XG
 
Perhaps this:-
Code:
[COLOR="Navy"]Sub[/COLOR] MG17Jun25
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] t
[COLOR="Navy"]Dim[/COLOR] Dic [COLOR="Navy"]As[/COLOR] Object, oTxt [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String,[/COLOR] k [COLOR="Navy"]As[/COLOR] Variant, Ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
t = Timer
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
[COLOR="Navy"]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    [COLOR="Navy"]With[/COLOR] Application
        oTxt = Join(.Transpose(.Transpose(Dn.Resize(, 11))), ",")
    [COLOR="Navy"]End[/COLOR] With
    [COLOR="Navy"]If[/COLOR] Not Dic.Exists(oTxt) [COLOR="Navy"]Then[/COLOR]
        Dic.Add oTxt, Dn
    [COLOR="Navy"]Else[/COLOR]
        [COLOR="Navy"]Set[/COLOR] Dic(oTxt) = Union(Dic(oTxt), Dn)
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
'[COLOR="Green"][B][r1] = Timer - t[/B][/COLOR]
Application.ScreenUpdating = False
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] k [COLOR="Navy"]In[/COLOR] Dic.keys
    c = c + 1
    [COLOR="Navy"]If[/COLOR] Dic(k).Count > 1 [COLOR="Navy"]Then[/COLOR]
        Dic(k).Offset(1).Resize(Dic(k).Count - 1, 12).ClearContents
        '[COLOR="Green"][B]Nb:- Alter the 20 in ".Resize(, 20)" in the following line to the number of columns you want to colour[/B][/COLOR]
        Dic(k).Resize(, 20).Interior.ColorIndex = IIf(c Mod 2 = 0, 20, xlNone) '[COLOR="Green"][B] Remove this line to stop colouring[/B][/COLOR]
     [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] k
Application.ScreenUpdating = True
'[COLOR="Green"][B][s1] = Timer - t[/B][/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0

Excel Facts

Move date out one month or year
Use =EDATE(A2,1) for one month later. Use EDATE(A2,12) for one year later.
Perhaps this:-
Code:
[COLOR=Navy]Sub[/COLOR] MG17Jun25
[COLOR=Navy]Dim[/COLOR] Rng [COLOR=Navy]As[/COLOR] Range, Dn [COLOR=Navy]As[/COLOR] Range, c [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long,[/COLOR] t
[COLOR=Navy]Dim[/COLOR] Dic [COLOR=Navy]As[/COLOR] Object, oTxt [COLOR=Navy]As[/COLOR] [COLOR=Navy]String,[/COLOR] k [COLOR=Navy]As[/COLOR] Variant, Ac [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long[/COLOR]
t = Timer
[COLOR=Navy]Set[/COLOR] Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
[COLOR=Navy]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare
[COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] Dn [COLOR=Navy]In[/COLOR] Rng
    [COLOR=Navy]With[/COLOR] Application
        oTxt = Join(.Transpose(.Transpose(Dn.Resize(, 11))), ",")
    [COLOR=Navy]End[/COLOR] With
    [COLOR=Navy]If[/COLOR] Not Dic.Exists(oTxt) [COLOR=Navy]Then[/COLOR]
        Dic.Add oTxt, Dn
    [COLOR=Navy]Else[/COLOR]
        [COLOR=Navy]Set[/COLOR] Dic(oTxt) = Union(Dic(oTxt), Dn)
    [COLOR=Navy]End[/COLOR] If
[COLOR=Navy]Next[/COLOR]
'[COLOR=Green][B][r1] = Timer - t[/B][/COLOR]
Application.ScreenUpdating = False
[COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] k [COLOR=Navy]In[/COLOR] Dic.keys
    c = c + 1
    [COLOR=Navy]If[/COLOR] Dic(k).Count > 1 [COLOR=Navy]Then[/COLOR]
        Dic(k).Offset(1).Resize(Dic(k).Count - 1, 12).ClearContents
        '[COLOR=Green][B]Nb:- Alter the 20 in ".Resize(, 20)" in the following line to the number of columns you want to colour[/B][/COLOR]
        Dic(k).Resize(, 20).Interior.ColorIndex = IIf(c Mod 2 = 0, 20, xlNone) '[COLOR=Green][B] Remove this line to stop colouring[/B][/COLOR]
     [COLOR=Navy]End[/COLOR] If
[COLOR=Navy]Next[/COLOR] k
Application.ScreenUpdating = True
'[COLOR=Green][B][s1] = Timer - t[/B][/COLOR]
[COLOR=Navy]End[/COLOR] [COLOR=Navy]Sub[/COLOR]
Regards Mick

Sorry for the extremely late reply Mick, a combination of the above and previous solutions you kindly provided worked wonders. Unfortunately out automatic exporting/reporting systems has had some updates to provide us with some more meaningful information - as a result the original/raw dataset we are working with previously has now changed somewhat.

eGjN1x2.jpg


Now I'll explain as best I can;


  • 80% of content follows the rules/format of Row 2 - that is yellow columns are identical for rows I want to merge/delete duplicates while the original columns are the unique information I need to keep.
  • The remaining 20% is what has changed with the new dataset - unfortunately these entries only match on the 'Case File' column which causes issues for the original solutions you posted because it merges approximately (depending on the dataset) anywhere between 200-2000 entries all under the same 'Case File Number'. The unique columns are again marked orange, the red columns are blank, and what I would love to sort on are yellow.

My dream solution would be to continue to merge/delete duplicates for the 80% of data (following Row 2 and your previous solutions) and then simple fit the remaining 20% (Row 4 example) among the previously merged data.

The issue I have is if I pre-sort the data (including the 80% AND 20%) by Misc #2 and Misc #3 columns (Data and Time unique to all 100% of the data), when your fantastic code runs against the new dataset we run into all sorts of issues as you can imagine. And if I leave it unsorted, the issue occurs that I explained before, the 80% data that your code is matching on and then merge/deleting dupes works wonders, but when it gets down the the 20% (currently being grouped at the bottom of the dataset as we export on Employee Number) all the new data is merged under the one 'Case File'.

Is there anyway to have your code only run on rows that contain (this is me brainstorming here) data in columns a, b, c (this will then exclude the 20% because the red columns are blank), group everything nicely adding the xl lines around each section and THEN sort the remaining 20% to slot between these sections (NOTE: Not among the sections already merged).

I hope this makes sense - happy to provide more information if required!
 
Last edited:
Upvote 0
I'm afraid this is all too time consuming and difficult to understand, this started at the beginning of June, A long time !!!.
If you can Start again with an explanation of the logic to cope with both situations and a simple example with the expected results, I'll have another look !!!
 
Last edited:
Upvote 0

Forum statistics

Threads
1,213,551
Messages
6,114,273
Members
448,559
Latest member
MrPJ_Harper

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top