Combine Rows With the Same Unique ID but Keep Them Separated by Month

[goob90]

I have employee data broken down by employee name, id, deduction month, deduction code, and deduction amount. I want to use VBA to combine the rows with the same employee id, list the deduction codes, and total the deduction amount. I want to do this but leave it separated by deduction month. Could someone point me in the right direction to do this?

 

[Peter_SSs]

I think just once would be okay.

Thanks. The code below does still actually repeat values like your original results but should be somewhat faster than the first code. However, I have not tested on large data so not absolutely sure. See how it goes. with your data.

Sub Rearrange_v2()
  Dim d As Object
  Dim a As Variant, b As Variant
  Dim i As Long, k As Long, r As Long
  Dim s As String

  Set d = CreateObject("Scripting.Dictionary")
  a = Range("A2", Range("E" & Rows.Count).End(xlUp)).Value
  ReDim b(1 To UBound(a), 1 To 5)
  For i = 1 To UBound(a)
    s = a(i, 1) & ";" & a(i, 2) & ":" & a(i, 3)
    If Not d.exists(s) Then
      k = k + 1
      d(s) = k
      b(k, 1) = a(i, 1): b(k, 2) = a(i, 2): b(k, 3) = a(i, 3): b(k, 4) = a(i, 4): b(k, 5) = a(i, 5)
    Else
      r = d(s)
      b(r, 4) = b(r, 4) & "," & a(i, 4): b(r, 5) = b(r, 5) + a(i, 5)
    End If
  Next i
  Application.ScreenUpdating = False
  With Range("G2").Resize(k, 5)
    .Value = b
    .Columns.AutoFit
  End With
  Application.ScreenUpdating = True
End Sub

 

[goob90]

Thanks. The code below does still actually repeat values like your original results but should be somewhat faster than the first code. However, I have not tested on large data so not absolutely sure. See how it goes. with your data.

Sub Rearrange_v2()
  Dim d As Object
  Dim a As Variant, b As Variant
  Dim i As Long, k As Long, r As Long
  Dim s As String

  Set d = CreateObject("Scripting.Dictionary")
  a = Range("A2", Range("E" & Rows.Count).End(xlUp)).Value
  ReDim b(1 To UBound(a), 1 To 5)
  For i = 1 To UBound(a)
    s = a(i, 1) & ";" & a(i, 2) & ":" & a(i, 3)
    If Not d.exists(s) Then
      k = k + 1
      d(s) = k
      b(k, 1) = a(i, 1): b(k, 2) = a(i, 2): b(k, 3) = a(i, 3): b(k, 4) = a(i, 4): b(k, 5) = a(i, 5)
    Else
      r = d(s)
      b(r, 4) = b(r, 4) & "," & a(i, 4): b(r, 5) = b(r, 5) + a(i, 5)
    End If
  Next i
  Application.ScreenUpdating = False
  With Range("G2").Resize(k, 5)
    .Value = b
    .Columns.AutoFit
  End With
  Application.ScreenUpdating = True
End Sub

Thank you so much! It work's great!

 

[Peter_SSs]

Thank you so much! It work's great!

Good news! Thanks for letting us know.