Need VBA to auto-sum two fields

I'm fairly confident in my ability to edit VBA, but starting from scratch is a little more challenging.

I have a file with production numbers, sorted by product code. The nature of my business is that some partial pallets get held to the next day in order to fill them to the top with product. So, for daily yields, I need to take out the previous day's production from today's numbers. So, my file contains code "1234" with "-1" pallet and "-500" lbs. and a second line (today's totals) with code "1234", "15" pallets and "15000" lbs. I want the macro to search for duplicate product codes, combine the two pallet and lb. numbers and then delete the line with the negative amounts.

So the result of the below lines would be a single line showing 14 pallets and 14500 lbs.

A B C D

1234 description -1 -500

1234 description 15 15000

of course, this would need to loop until no more duplicates are found. And, to add a snag, or error-handling, if there are no duplicates, but still have negatives in either pallet or weight field, it should ignore those (and I'll deal with them manually).

Thanks in advance for any help you can offer.

Assuming that the data are in columns A to D and have headers in row 1:

Sub Combine()
    Dim r As Long
    Dim m As Long
    Application.ScreenUpdating = False
    m = Range("A" & Rows.Count).End(xlUp).Row
    Range("A1").CurrentRegion.Sort Key1:=Range("A1"), Header:=xlYes
    For r = m - 1 To 2 Step -1
        If Range("A" & r + 1).Value = Range("A" & r).Value Then
            Range("C" & r).Value = Range("C" & r).Value + Range("C" & r + 1).Value
            Range("D" & r).Value = Range("D" & r).Value + Range("D" & r + 1).Value
            Range("A" & r + 1).EntireRow.Delete
        End If
    Next r
    Application.ScreenUpdating = True
End Sub

If you don't have headers in row 1, use

    For r = m - 1 To 1 Step -1

6 Replies

German_Chris
Iron Contributor
Jul 12, 2021
Why do you not use a Pivottable or normal Grouping or PowerQuery to Group and get a new Table.
- Riny_van_Eekelen
  Platinum Contributor
  Jul 12, 2021
  German_Chris You are sooooo right. Quite amazing to see that people still choose to revert to complicated VBA solutions to do very simple things, rather than using built-in functionalities that require a few button clicks. No coding required. Attaching a workbook that demonstrates just that.
  randompanda2.xlsx105 KB
  - German_Chris
    Iron Contributor
    Jul 12, 2021
    Thumbs up Riny_van_Eekelen
- RandomPanda
  Brass Contributor
  Jul 12, 2021
  German_Chris Thanks for the reply.
  I need to keep the formatting of the original in order to copy/paste into our P&L spreadsheet. So, a pivot table wouldn't necessarily be the best solution (I have other fields than just the 3 mentioned that need to transfer over as well). A pivot table, even though a macro to create it would make it faster, is probably not worth the hassle. I don't think I've ever used a Power Query, so I'm not sure if that would work or not.
  It's a fairly simple text file that I download from our SOR and then manipulate (as explained) after some research. Then I copy the info to a shared workbook where it does a bunch of other calculations.
  - HansVogelaar
    MVP
    Jul 12, 2021
    RandomPanda
    
    Assuming that the data are in columns A to D and have headers in row 1:
    
    Sub Combine() Dim r As Long Dim m As Long Application.ScreenUpdating = False m = Range("A" & Rows.Count).End(xlUp).Row Range("A1").CurrentRegion.Sort Key1:=Range("A1"), Header:=xlYes For r = m - 1 To 2 Step -1 If Range("A" & r + 1).Value = Range("A" & r).Value Then Range("C" & r).Value = Range("C" & r).Value + Range("C" & r + 1).Value Range("D" & r).Value = Range("D" & r).Value + Range("D" & r + 1).Value Range("A" & r + 1).EntireRow.Delete End If Next r Application.ScreenUpdating = True End Sub
    
    If you don't have headers in row 1, use
    
    For r = m - 1 To 1 Step -1

Forum Discussion

Need VBA to auto-sum two fields

6 Replies

Resources