Consolidate Rows with VBA

[RobWolf]

I have a sheet that a user inputs rows of information using a user form. Some rows will contain the same data except a quantity, How can I consolidate this information with VBA?
I pasted a very simplified example of what I need below.

Thank you for any help.

 

[JEC]

How about (Windows)

Sub jec()
 Dim ar, j As Long
 ar = Range("A2").CurrentRegion
 With CreateObject("scripting.dictionary")
   For j = 2 To UBound(ar)
     If Not .exists(ar(j, 1)) Then
       .Item(ar(j, 1)) = Array(ar(j, 1), ar(j, 2), ar(j, 3))
     Else
       .Item(ar(j, 1)) = Array(ar(j, 1), ar(j, 2), .Item(ar(j, 1))(2) + ar(j, 3))
     End If
   Next
   Range("E2").Resize(.Count, 3) = Application.Index(.items, 0, 0)
 End With
End Sub

 

[RobWolf]

How about (Windows)

Sub jec()
 Dim ar, j As Long
 ar = Range("A2").CurrentRegion
 With CreateObject("scripting.dictionary")
   For j = 2 To UBound(ar)
     If Not .exists(ar(j, 1)) Then
       .Item(ar(j, 1)) = Array(ar(j, 1), ar(j, 2), ar(j, 3))
     Else
       .Item(ar(j, 1)) = Array(ar(j, 1), ar(j, 2), .Item(ar(j, 1))(2) + ar(j, 3))
     End If
   Next
   Range("E2").Resize(.Count, 3) = Application.Index(.items, 0, 0)
 End With
End Sub

thank you. this works perfect for the example I posted. but I might of overly simplified it. below is an actual example of what we might get. I need to compare "thickness" and "desc" if they are the same consolidate the rows and add the board feet together. Also it would be great if it deleted the original information and replaced it with the new consolidated information

 

[JEC]

assuming your data starts in A4

Sub jec()
 Dim ar, dic, k, j As Long
 Set dic = CreateObject("scripting.dictionary")
 With Range("A4").CurrentRegion
   ar = .Value
   For j = 1 To UBound(ar)
     k = ar(j, 1) & ar(j, 4)
     If Not dic.exists(k) Then
       dic(k) = Array(ar(j, 1), ar(j, 2), ar(j, 3), ar(j, 4), ar(j, 5), ar(j, 6))
     Else
       dic(k) = Array(ar(j, 1), ar(j, 2), ar(j, 3), ar(j, 4), dic(ar(j, 1))(4) + ar(j, 5), ar(j, 6))
     End If
   Next
   .ClearContents
   .Resize(dic.Count, 3) = Application.Index(dic.items, 0, 0)
 End With
End Sub

 

[RobWolf]

assuming your data starts in A4

Sub jec()
 Dim ar, dic, k, j As Long
 Set dic = CreateObject("scripting.dictionary")
 With Range("A4").CurrentRegion
   ar = .Value
   For j = 1 To UBound(ar)
     k = ar(j, 1) & ar(j, 4)
     If Not dic.exists(k) Then
       dic(k) = Array(ar(j, 1), ar(j, 2), ar(j, 3), ar(j, 4), ar(j, 5), ar(j, 6))
     Else
       dic(k) = Array(ar(j, 1), ar(j, 2), ar(j, 3), ar(j, 4), dic(ar(j, 1))(4) + ar(j, 5), ar(j, 6))
     End If
   Next
   .ClearContents
   .Resize(dic.Count, 3) = Application.Index(dic.items, 0, 0)
 End With
End Sub

When I try to run this I get this error message

 

[JEC]

Ah yes a typo, change

dic(ar(j,1))(4)

To

dic(k)(4)

 

[JEC]

And also: (sry did not test)

.Resize(dic.Count, 3)

To

.Resize(dic.Count, 6)

 

[RobWolf]

And also: (sry did not test)

.Resize(dic.Count, 3)

To

.Resize(dic.Count, 6)

Nice!! Thank you. I would never have figured that out.