merge duplicate rows

[marreco]

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

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

 

[DanteAmor]

Try this

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

 

[marreco]

Hi Dante, your code work well, but I made a mistake.

Can you adapt to this?

Nº da NFe <tbody> </tbody>	Série <tbody> </tbody>	Data Emissão <tbody> </tbody>	BASE ICMS ST <tbody> </tbody>	CST <tbody> </tbody>	Código do Produto <tbody> </tbody>	Your Code Result <tbody> </tbody>	I would like this <tbody> </tbody>
2805201 <tbody> </tbody>	3 <tbody> </tbody>	27/06/2019 <tbody> </tbody>	94,21 <tbody> </tbody>	210 <tbody> </tbody>	100388 <tbody> </tbody>	94,21 | 52,19 | 100388 | 102401 Considerar BC ST <tbody> </tbody>	94,21 | 100388 | 52,19 | 102401 Considerar BC ST <tbody> </tbody>
2805201 <tbody> </tbody>	3 <tbody> </tbody>	27/06/2019 <tbody> </tbody>	52,19 <tbody> </tbody>	510 <tbody> </tbody>	102401 <tbody> </tbody>

<tbody>
</tbody>

 

[DanteAmor]

Updated 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

 

[marreco]

Man you are the best!!

This help me a lot!!

Thank you!!!!!!!!!!!!!!

 

[DanteAmor]

Man you are the best!!

This help me a lot!!

Thank you!!!!!!!!!!!!!!

I'm glad to help you. Thanks for the feedback.