Combine rows with duplicate and variable values into one row

[Trobiosta]

Hey, this is my first post and I'm kinda new and english is not my native language so I would appreciate anyone trying to help me out.

So the thing is, I have an Excel in which range A:D has a lot of common values but then range E:AB has values that can be the same or different. What I want is to create an unique row when lets say data A1:D4 is the same for each column and add the values from E:AB based on A:D being the same.

On the upper table you can see what I have.

And on the lower one there is what I want to achieve. I have been searching different forums etc and I found something about arrays but I dont know how to work with those yet, I'm still doing simple macros using what I find on the Internet and changing it to suit my needs, but this one I'm stucked.

 

[DanteAmor]

Hi and welcome to MrExcel.

Try the following macro, your data on sheet1 starting at A1, the results on sheet2 in cell A1 onwards.

Sub CombineRows()
  Dim a As Variant, b As Variant, ky As String
  Dim i As Long, j As Long, k As Long, m As Long, n As Long
  Dim dic As Object
  
  Set dic = CreateObject("Scripting.Dictionary")
  
  With Sheets("Sheet1").Range("A1").CurrentRegion
    a = .Value
    n = WorksheetFunction.CountA(.Offset(1, 4))
  End With
  ReDim b(1 To UBound(a, 1), 1 To n)
  
  For i = 1 To UBound(a, 1)
    ky = a(i, 1) & "|" & a(i, 2) & "|" & a(i, 3) & "|" & a(i, 4)
    If Not dic.exists(ky) Then
      j = j + 1
      dic(ky) = j
      b(j, 1) = a(i, 1)
      b(j, 2) = a(i, 2)
      b(j, 3) = a(i, 3)
      b(j, 4) = a(i, 4)
    End If
    j = dic(ky)
    For k = 5 To UBound(a, 2)
      If a(i, k) = "" Then Exit For
      For m = 5 To UBound(b, 2)
        If b(j, m) = "" Then
          b(j, m) = a(i, k)
          Exit For
        End If
      Next
    Next
  Next
  
  Sheets("Sheet2").Range("A1").Resize(dic.Count, UBound(b, 2)).Value = b
End Sub

 

[Trobiosta]

Hi and welcome to MrExcel.

Try the following macro, your data on sheet1 starting at A1, the results on sheet2 in cell A1 onwards.

Sub CombineRows()
  Dim a As Variant, b As Variant, ky As String
  Dim i As Long, j As Long, k As Long, m As Long, n As Long
  Dim dic As Object
 
  Set dic = CreateObject("Scripting.Dictionary")
 
  With Sheets("Sheet1").Range("A1").CurrentRegion
    a = .Value
    n = WorksheetFunction.CountA(.Offset(1, 4))
  End With
  ReDim b(1 To UBound(a, 1), 1 To n)
 
  For i = 1 To UBound(a, 1)
    ky = a(i, 1) & "|" & a(i, 2) & "|" & a(i, 3) & "|" & a(i, 4)
    If Not dic.exists(ky) Then
      j = j + 1
      dic(ky) = j
      b(j, 1) = a(i, 1)
      b(j, 2) = a(i, 2)
      b(j, 3) = a(i, 3)
      b(j, 4) = a(i, 4)
    End If
    j = dic(ky)
    For k = 5 To UBound(a, 2)
      If a(i, k) = "" Then Exit For
      For m = 5 To UBound(b, 2)
        If b(j, m) = "" Then
          b(j, m) = a(i, k)
          Exit For
        End If
      Next
    Next
  Next
 
  Sheets("Sheet2").Range("A1").Resize(dic.Count, UBound(b, 2)).Value = b
End Sub

Hi, thanks for your answer. Sadly, I run into a problem when first trying this code on the actual Excel and it seems to happen that when a continuous serie of values are the same in columns A:D but there is a minor change in between the macro cuts that one out and doesn't create that new row which is not a duplicate of the previous and upcoming ones.

Here I did a variation in the examples I first showed. We have that company A uses code 1 for customer Apple in every price, but there is one row in which the price is 12 that doesn't show in the final result. Besides that there is some centers that appear twice. If its possible I would like them to show just once but that's a minor problem I might be able to fix myself. About the little change when it happens in between I don't know what to do there myself.

 

[DanteAmor]

My bad, I didn't put a counter. Try the following code:

Sub CombineRows()
  Dim a As Variant, b As Variant, ky As String
  Dim i As Long, j As Long, k As Long, m As Long, n As Long, p As Long
  Dim dic As Object
  
  Set dic = CreateObject("Scripting.Dictionary")
  
  With Sheets("Sheet1").Range("A1").CurrentRegion
    a = .Value
    n = WorksheetFunction.CountA(.Offset(1, 4))
  End With
  ReDim b(1 To UBound(a, 1), 1 To n)
  
  For i = 1 To UBound(a, 1)
    ky = a(i, 1) & "|" & a(i, 2) & "|" & a(i, 3) & "|" & a(i, 4)
    If Not dic.exists(ky) Then
      p = p + 1
      dic(ky) = p
      b(p, 1) = a(i, 1)
      b(p, 2) = a(i, 2)
      b(p, 3) = a(i, 3)
      b(p, 4) = a(i, 4)
    End If
    j = dic(ky)
    For k = 5 To UBound(a, 2)
      If a(i, k) = "" Then Exit For
      For m = 5 To UBound(b, 2)
        If b(j, m) = "" Then
          b(j, m) = a(i, k)
          Exit For
        End If
      Next
    Next
  Next
  Sheets("Sheet2").Cells.ClearContents
  Sheets("Sheet2").Range("A1").Resize(dic.Count, UBound(b, 2)).Value = b
End Sub

 

[Trobiosta]

My bad, I didn't put a counter. Try the following code:

Sub CombineRows()
  Dim a As Variant, b As Variant, ky As String
  Dim i As Long, j As Long, k As Long, m As Long, n As Long, p As Long
  Dim dic As Object
 
  Set dic = CreateObject("Scripting.Dictionary")
 
  With Sheets("Sheet1").Range("A1").CurrentRegion
    a = .Value
    n = WorksheetFunction.CountA(.Offset(1, 4))
  End With
  ReDim b(1 To UBound(a, 1), 1 To n)
 
  For i = 1 To UBound(a, 1)
    ky = a(i, 1) & "|" & a(i, 2) & "|" & a(i, 3) & "|" & a(i, 4)
    If Not dic.exists(ky) Then
      p = p + 1
      dic(ky) = p
      b(p, 1) = a(i, 1)
      b(p, 2) = a(i, 2)
      b(p, 3) = a(i, 3)
      b(p, 4) = a(i, 4)
    End If
    j = dic(ky)
    For k = 5 To UBound(a, 2)
      If a(i, k) = "" Then Exit For
      For m = 5 To UBound(b, 2)
        If b(j, m) = "" Then
          b(j, m) = a(i, k)
          Exit For
        End If
      Next
    Next
  Next
  Sheets("Sheet2").Cells.ClearContents
  Sheets("Sheet2").Range("A1").Resize(dic.Count, UBound(b, 2)).Value = b
End Sub

Hey sorry for the late answer, I have been busy lately. So what I did in the end was using the first code, but before running it, I ordered the whole data using the order (ordenar in spanish) tool. After that the error couldnt repeat again because as I mentioned, it only happened if the values on the left were the same with a diferent value in the middle. Anyways thanks for coding a fix for it. I hope this serves someone one day as it did for me.

 

[DanteAmor]

Im glad to help you, thanks for the feedback.