merge duplicate rows

marreco

marreco

Well-known Member
Joined
Jan 1, 2011
Messages
609
Office Version
  1. 2010
Platform
  1. Windows
Hi Atry adapt a code, but din't work.
Before
Nº da NFe Série Data Emissão BASE ICMS ST CST Código do Produto
2805151 3 43643 110,78 210 101173
2805153 3 43643 100,44 510 100092
2805155 3 43643 1028,35 210 106447
2805157 3 43643 50,67 570 402850
2805159 3 43643 100,44 510 100092
2805161 3 43643 377,03 510 105533
2805163 3 43643 100,44 510 100092
2805165 3 43643 80,92 510 100308
2805167 3 43643 100,44 510 100092
2805169 3 43643 279,49 810 101181
2805171 3 43643 74,09 210 106995
2805173 3 43643 100,44 510 100092
2805175 3 43643 62,06 210 106997
2805177 3 43643 34,1 510 105174
2805179 3 43643 205,67 210 106447
2805181 3 43643 245,35 210 105065
2805183 3 43643 63,91 210 106140
2805185 3 43643 142,06 510 100296
2805187 3 43643 37,05 810 304070
2805191 3 43643 28,72 510 106391
2805191 3 43643 63,17 510 105359
2805191 3 43643 66,8 510 106403
2805197 3 43643 38,24 510 110116
2805199 3 43643 187,04 210 106573
2805201 3 43643 94,21 210 100388
2805201 3 43643 52,19 510 102401
2805203 3 43643 157,54 210 102408
2805206 3 43643 83,15 210 401150

After
Nº da NFe Série Data Emissão BASE ICMS ST CST Código do Produto Restult
2805151 3 43643 110,78 210 101173
2805153 3 43643 100,44 510 100092
2805155 3 43643 1028,35 210 106447
2805157 3 43643 50,67 570 402850
2805159 3 43643 100,44 510 100092
2805161 3 43643 377,03 510 105533
2805163 3 43643 100,44 510 100092
2805165 3 43643 80,92 510 100308
2805167 3 43643 100,44 510 100092
2805169 3 43643 279,49 810 101181
2805171 3 43643 74,09 210 106995
2805173 3 43643 100,44 510 100092
2805175 3 43643 62,06 210 106997
2805177 3 43643 34,1 510 105174
2805179 3 43643 205,67 210 106447
2805181 3 43643 245,35 210 105065
2805183 3 43643 63,91 210 106140
2805185 3 43643 142,06 510 100296
2805187 3 43643 37,05 810 304070
2805191 3 43643 28,72 510 106391 28,72 | 63,17 | 66,8 | 106391 | 105359 | 106403 Considerar BC ST
2805197 3 43643 38,24 510 110116
2805199 3 43643 187,04 210 106573
2805201 3 43643 94,21 210 100388 94,21 | 52,19 | 100388 | 102401 Considerar BC ST
2805203 3 43643 157,54 210 102408
2805206 3 43643 83,15 210 401150

Code: 
Sub MG02Sep59()'By   : Mick
'Fonte:https://www.mrexcel.com/forum/excel-questions/1021341-vba-merge-duplicate-rows-sum-values-certain-column.html
Dim Rng As Range, Dn As Range, n As Long, nRng As Range
Set Rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
    With CreateObject("scripting.dictionary")
        .CompareMode = vbTextCompare
        For Each Dn In Rng
            If Not .Exists(Dn.Value) Then
                .Add Dn.Value, Dn
            Else
                If nRng Is Nothing Then Set nRng = Dn Else Set nRng = Union(nRng, Dn)
                .Item(Dn.Value).Offset(, 3) = .Item(Dn.Value).Offset(, 3) & " | " & Dn.Offset(, 3)
                .Item(Dn.Value).Offset(, 5) = .Item(Dn.Value).Offset(, 5) & " | " & Dn.Offset(, 5)
            End If
        Next
        If Not nRng Is Nothing Then nRng.EntireRow.Delete
    End With
End Sub
 

Excel Facts

How to total the visible cells?
From the first blank cell below a filtered data set, press Alt+=. Instead of SUM, you will get SUBTOTAL(9,)
Sort by date Sort by votes
Try this

Code: 
Sub merge_duplicate()
  Dim c As Range, r As Range, f As Range, cell As String, c1 As String, c2 As String
  Dim i As Long, rn As Range
  Set rn = Range("A" & Range("A" & Rows.Count).End(xlUp).Row + 1)
  For Each c In Range("A2", Range("A" & Rows.Count).End(xlUp))
    c1 = c.Offset(, 3)
    c2 = c.Offset(, 5)
    Set r = Range("A" & c.Row, Range("A" & Rows.Count).End(xlUp))
    Set f = r.Find(c, , xlValues, xlWhole)
    If Not f Is Nothing And f.Address <> c.Address Then
      cell = f.Address
      Set rn = Union(rn, f)
      Do
        c1 = c1 & " | " & f.Offset(, 3)
        c2 = c2 & " | " & f.Offset(, 5)
        Set f = r.FindNext(f)
      Loop While Not f Is Nothing And f.Address <> cell And f.Address <> c.Address
      c.Offset(, 6) = c1 & " | " & c2 & " Considerar BC ST"
    End If
  Next
  rn.EntireRow.Delete
End Sub
 
Upvote 0
Hi Dante, your code work well, but I made a mistake.

Can you adapt to this?

[TABLE="class: grid, width: 500, align: left"]
<tbody>[TR]
[TD][TABLE="width: 69"]
<tbody>[TR]
[TD="width: 69"]Nº da NFe[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[TD][TABLE="width: 39"]
<tbody>[TR]
[TD="width: 39"]Série[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[TD] [TABLE="width: 88"]
<tbody>[TR]
[TD="width: 88"]Data Emissão[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[TD][TABLE="width: 89"]
<tbody>[TR]
[TD="width: 89"]BASE ICMS ST[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[TD][TABLE="width: 29"]
<tbody>[TR]
[TD="width: 29"]CST[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[TD][TABLE="width: 124"]
<tbody>[TR]
[TD="width: 124"]Código do Produto[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[TD][TABLE="width: 314"]
<tbody>[TR]
[TD="width: 314"]Your Code Result[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[TD][TABLE="width: 314"]
<tbody>[TR]
[TD="width: 314"]I would like this[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[/TR]
[TR]
[TD][TABLE="width: 69"]
<tbody>[TR]
[TD="class: xl65, width: 69, align: right"]2805201[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[TD][TABLE="width: 39"]
<tbody>[TR]
[TD="class: xl65, width: 39, align: right"]3[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[TD][TABLE="width: 88"]
<tbody>[TR]
[TD="class: xl65, width: 88, align: right"]27/06/2019[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[TD][TABLE="width: 89"]
<tbody>[TR]
[TD="class: xl65, width: 89, align: right"]94,21[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[TD][TABLE="width: 29"]
<tbody>[TR]
[TD="class: xl65, width: 29, align: right"]210[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[TD][TABLE="width: 124"]
<tbody>[TR]
[TD="class: xl65, width: 124, align: right"]100388[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[TD][TABLE="width: 314"]
<tbody>[TR]
[TD="width: 314"]94,21 | 52,19 | 100388 | 102401 Considerar BC ST [/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[TD][TABLE="width: 314"]
<tbody>[TR]
[TD="width: 314"]94,21 | 100388 | 52,19 | 102401 Considerar BC ST [/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[/TR]
[TR]
[TD][TABLE="width: 69"]
<tbody>[TR]
[TD="class: xl65, width: 69, align: right"]2805201[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[TD][TABLE="width: 39"]
<tbody>[TR]
[TD="class: xl65, width: 39, align: right"]3[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[TD][TABLE="width: 88"]
<tbody>[TR]
[TD="class: xl65, width: 88, align: right"]27/06/2019[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[TD][TABLE="width: 89"]
<tbody>[TR]
[TD="class: xl65, width: 89, align: right"]52,19[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[TD][TABLE="width: 29"]
<tbody>[TR]
[TD="class: xl65, width: 29, align: right"]510[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[TD][TABLE="width: 124"]
<tbody>[TR]
[TD="class: xl65, width: 124, align: right"]102401[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]
 
Upvote 0
Updated code:

Code: 
Sub merge_duplicate()
  Dim c As Range, r As Range, f As Range, cell As String, c1 As String
  Dim i As Long, rn As Range
  Set rn = Range("A" & Range("A" & Rows.Count).End(xlUp).Row + 1)
  For Each c In Range("A2", Range("A" & Rows.Count).End(xlUp))
    c1 = c.Offset(, 3) & " | " & c.Offset(, 5)
    Set r = Range("A" & c.Row, Range("A" & Rows.Count).End(xlUp))
    Set f = r.Find(c, , xlValues, xlWhole)
    If Not f Is Nothing And f.Address <> c.Address Then
      cell = f.Address
      Set rn = Union(rn, f)
      Do
        c1 = c1 & " | " & f.Offset(, 3) & " | " & f.Offset(, 5)
        Set f = r.FindNext(f)
      Loop While Not f Is Nothing And f.Address <> cell And f.Address <> c.Address
      c.Offset(, 6) = c1 & " | " & " Considerar BC ST"
    End If
  Next
  rn.EntireRow.Delete
End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Question Question
Excel VBA Merge Duplicate rows and sum values in certain column
Replies
1
Views
3K
DanteAmor
DanteAmor

Forum statistics

Threads
1,223,896
Messages
6,175,260
Members
452,627
Latest member
KitkatToby

Share this page

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