VBA to consolidate and sum values

[DDePoy]

Hello,

I recorded a Macro using the Consolidation tool however when I run the Macro, it does not complete the task.

Here is what it looks like:

Sub Consolidate()
'
' Consolidate Macro
'


'
Sheets("Inventory Value Report").Select
Range("D1").Select
Selection.Consolidate Sources:=Array( _
"'C:\Users\ddep9969\AppData\Local\Microsoft\Windows\INetCache\Content.Outlook\U7MD7TOU\[Inventory Value Report 06062019 (002).xls]Inventory Value Report'!R1C1:R914C2" _
, _
"'C:\Users\ddep9969\AppData\Local\Microsoft\Windows\INetCache\Content.Outlook\U7MD7TOU\[Inventory Value Report 06062019 (002).xls]Inventory Value Report'!R1C1:R1200C2" _
), Function:=xlSum, TopRow:=True, LeftColumn:=True, CreateLinks:=False
End Sub

Can someone help me with creating a Module that locates the duplicates in column A and sums the values in column B:

Item Number	Quantity on Hand
3029891	1
5101078	1.08
7002294	0.5
7002294	3
0671677	0.75
5469259	1.5
2404135	1
2404135	0
1283456	4
7544737	1
1829748	0
2822383	0
2822383	1.25
8953028	0
6259477	1.58
4507214	2
2006559	1.35
4507234	0.5
4507263	1
5518529	0.83
4069870	0
1142381	0.67
4838704	0

<colgroup><col span="2"></colgroup><tbody>
</tbody>

This list will vary in size so I would like for it to look for the last row with data and complete the task within that range.

Any help would greatly be appreciated!!

 

[kweaver]

You could fill down a formula starting in C2:

=SUMIF($A$2:$A$24,A2,$B$2:$B$24)

If you want a macro:

Sub CombineItems()
Dim LR As Long, i As Integer, MyRg1 As Range, MyRg2 As Range
LR = Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To LR
    Set MyRg1 = Range("A2:A" & LR)
    Set MyRg2 = Range("B2:B" & LR)
    Cells(i, "C") = WorksheetFunction.SumIf(MyRg1, (Range("A" & i)), MyRg2)
Next i
End Sub

Then, you could remove duplicates if that's what you need.

 

[kweaver]

Sub CombineItems()
Dim LR As Long, i As Integer, MyRg1 As Range, MyRg2 As Range
LR = Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To LR
    Set MyRg1 = Range("A2:A" & LR)
    Set MyRg2 = Range("B2:B" & LR)
    Cells(i, "C") = WorksheetFunction.SumIf(MyRg1, (Range("A" & i)), MyRg2)
Next i

Set MyRg1 = Range("A1:C" & LR)
MyRg1.RemoveDuplicates Columns:=1, Header:=xlYes

End Sub

 

[Rick Rothstein]

Are you duplicates always next to each other as your example shows? If so, you can use this macro...

Sub consolidate()
  Dim Ar As Range
  With Range("A2", Cells(Rows.Count, "A").End(xlUp))
    .Value = Evaluate("IF(" & .Address & "=" & .Offset(-1).Address & ",""""," & .Address & ")")
    With .SpecialCells(xlBlanks)
      For Each Ar In .Areas
        Ar.Offset(-1, 1) = Ar.Offset(-1, 1) + Application.Sum(Ar.Offset(, 1))
      Next
    .EntireRow.Delete
    End With
  End With
End Sub

 

[Rick Rothstein]

Are you duplicates always next to each other as your example shows? If so, you can use this macro...

Sub consolidate()
  Dim Ar As Range
  With Range("A2", Cells(Rows.Count, "A").End(xlUp))
    .Value = Evaluate("IF(" & .Address & "=" & .Offset(-1).Address & ",""""," & .Address & ")")
    With .SpecialCells(xlBlanks)
      For Each Ar In .Areas
        Ar.Offset(-1, 1) = Ar.Offset(-1, 1) + Application.Sum(Ar.Offset(, 1))
      Next
    .EntireRow.Delete
    End With
  End With
End Sub

And if they might not always be next to each other, then you can use this code instead (or in place of the above code as I think it might be faster). One difference between the codes... the above code overwrites the existing data with the new layout whereas the code below outputs to the two columns next to your data...

Sub Consolidate()
  Dim R As Long, Data As Variant
  Data = Range("A2", Cells(Rows.Count, "B").End(xlUp))
  With CreateObject("Scripting.Dictionary")
    For R = 1 To UBound(Data)
      .Item(Data(R, 1)) = .Item(Data(R, 1)) + Data(R, 2)
    Next
    Range("C2").Resize(.Count) = Application.Transpose(.Keys)
    Range("D2").Resize(.Count) = Application.Transpose(.Items)
  End With
End Sub

 

[DDePoy]

Thank you Rick!

You have helped me immensely today. I have one last issue that I am trying to get resolved to finish this project:

https://www.mrexcel.com/forum/excel...bsolute-reference-ref-errors.html#post5295175

Do you think you would be able to assist me once more?