Excel VBA to sum 2 fields based on multiple criteria and then copy some of the fields to a new sheet

[chillinsf49]

Hello,

I am have an urgent task for work and have gone through the various threads on this site, but, I could not find anything. I have to be able to quickly sum the total based on multiple criteria and remove the duplicate rows (Tab "Data". Then only certain columns are copied over to a worksheet in the same workbook (Tab "Output). There are about 100,000 rows with 40 columns, so using a SUMIF formula is not feasible since it takes up alot of memory.

For example:
There are 8 columns in Tab "Data". I would like to sum the Expense and HC columns if it meets these criteria: Date, Dept ID, Unit, and Acct Num. Then I would like to copy only a few columns from the Tab "Data" to a new sheet called "Output" in the same workbook. The new fields I need in Tab "Output" are Date, Dept ID, Unit, Acct Num, Expense, and HC. The Tab "Output" contains only 12 rows because there are 2 sets in Tab "Data" that matched the criteria; therefore, the Expense and HC values are summed and shown as one row.

Thank you advance for your help!

Tab "Data" - Columns A2 through H14
[TABLE="width: 620"]
<tbody>[TR]
[TD]Date[/TD]
[TD]Program[/TD]
[TD]Dept ID[/TD]
[TD]Unit[/TD]
[TD]Acct Level 1[/TD]
[TD]Acct Num[/TD]
[TD]Expense[/TD]
[TD]HC[/TD]
[/TR]
[TR]
[TD]Jan 31, 2018[/TD]
[TD]Technology[/TD]
[TD]1111[/TD]
[TD]ABC[/TD]
[TD]Emp Related[/TD]
[TD]24353[/TD]
[TD]$54[/TD]
[TD]-[/TD]
[/TR]
[TR]
[TD]Jan 31, 2018[/TD]
[TD]Technology[/TD]
[TD]1111[/TD]
[TD]ABC[/TD]
[TD]Postage/Courier Service[/TD]
[TD]79810[/TD]
[TD]$81[/TD]
[TD]-[/TD]
[/TR]
[TR]
[TD]Jan 31, 2018[/TD]
[TD]Technology[/TD]
[TD]1111[/TD]
[TD]ABC[/TD]
[TD]Travel and Other[/TD]
[TD]80545[/TD]
[TD]$77[/TD]
[TD]-[/TD]
[/TR]
[TR]
[TD]Jan 31, 2018[/TD]
[TD]Technology[/TD]
[TD]1111[/TD]
[TD]XYZ[/TD]
[TD]Travel[/TD]
[TD]87342[/TD]
[TD]($2,991)[/TD]
[TD]2.0[/TD]
[/TR]
[TR]
[TD]Jan 31, 2018[/TD]
[TD]Technology[/TD]
[TD]1111[/TD]
[TD]XYZ[/TD]
[TD]Travel[/TD]
[TD]87342[/TD]
[TD]$0[/TD]
[TD]5.0[/TD]
[/TR]
[TR]
[TD]Jan 31, 2018[/TD]
[TD]Technology[/TD]
[TD]1111[/TD]
[TD]EFG[/TD]
[TD]Travel and Misc[/TD]
[TD]80555[/TD]
[TD]$0[/TD]
[TD]-[/TD]
[/TR]
[TR]
[TD]Jan 31, 2018[/TD]
[TD]Technology[/TD]
[TD]1111[/TD]
[TD]ABC[/TD]
[TD]Bonus[/TD]
[TD]21930[/TD]
[TD]$3,626[/TD]
[TD]-[/TD]
[/TR]
[TR]
[TD]Jan 31, 2018[/TD]
[TD]Technology[/TD]
[TD]1111[/TD]
[TD]EFG[/TD]
[TD]Bonus[/TD]
[TD]21930[/TD]
[TD]$1,000[/TD]
[TD]-[/TD]
[/TR]
[TR]
[TD]Jan 31, 2018[/TD]
[TD]Technology[/TD]
[TD]1111[/TD]
[TD]EFG[/TD]
[TD]Bonus[/TD]
[TD]97897[/TD]
[TD]$594[/TD]
[TD]-[/TD]
[/TR]
[TR]
[TD]Feb 28, 2018[/TD]
[TD]Technology[/TD]
[TD]2222[/TD]
[TD]XYZ[/TD]
[TD]Management & Supervision[/TD]
[TD]49183[/TD]
[TD]$81,688[/TD]
[TD]5.0[/TD]
[/TR]
[TR]
[TD]Feb 28, 2018[/TD]
[TD]Technology[/TD]
[TD]2222[/TD]
[TD]XYZ[/TD]
[TD]Management & Supervision[/TD]
[TD]49183[/TD]
[TD]$11,887[/TD]
[TD]1.0[/TD]
[/TR]
[TR]
[TD]Feb 28, 2018[/TD]
[TD]Technology[/TD]
[TD]2222[/TD]
[TD]ABC[/TD]
[TD]Housekeeping Supply[/TD]
[TD]53421[/TD]
[TD]$34[/TD]
[TD]-[/TD]
[/TR]
</tbody>[/TABLE]


Tab "Output" - Columns A2 through F12
Date Dept ID Unit Acct Num Expense HC
Jan 31, 2018 1111 ABC 24353 $54 -
Jan 31, 2018 1111 ABC 79810 $81 -
Jan 31, 2018 1111 ABC 80545 $77 -
Jan 31, 2018 1111 XYZ 87342 ($2,991) 7.0
Jan 31, 2018 1111 EFG 80555 $0 -
Jan 31, 2018 1111 ABC 21930 $3,626 -
Jan 31, 2018 1111 EFG 21930 $1,000 -
Jan 31, 2018 1111 EFG 97897 $594 -
Feb 28, 2018 2222 XYZ 49183 $93,574 6.0
Feb 28, 2018 2222 ABC 53421 $34 -

 

[RSpin]

I believe this does what you are looking for:

Sub codingisfun()


Dim docname As String
Dim thisbook As Workbook
Dim dta As Worksheet
Dim otp As Worksheet
Dim Lrow As Long
Dim OutArr() As Variant
Dim InArr() As Variant
Dim Ran As Range
Dim BB As Long
Dim CC As Long
Dim DD As Integer


docname = ActiveWorkbook.Name
Set thisbook = Workbooks(docname)
Set dta = thisbook.Worksheets("Data")
Set otp = thisbook.Worksheets("Output")
Lrow = dta.Range("A200000").End(xlUp).Row
ReDim OutArr(1 To Lrow, 1 To 8)
ReDim InArr(1 To Lrow, 1 To 6)
Set Ran = dta.Range("A2:H" & Lrow)
OutArr = Ran
Lrow = 1


For BB = 1 To UBound(OutArr, 1)
    If OutArr(BB, 1) <> "" Then
        InArr(Lrow, 1) = OutArr(BB, 1) ' Date
        InArr(Lrow, 2) = OutArr(BB, 3) ' Dept ID
        InArr(Lrow, 3) = OutArr(BB, 4) ' Unit
        InArr(Lrow, 4) = OutArr(BB, 6) ' Acct Num
        InArr(Lrow, 5) = Val(OutArr(BB, 7)) ' Expense
        InArr(Lrow, 6) = Val(OutArr(BB, 8)) ' HC
        For DD = 1 To 8
            OutArr(BB, DD) = ""
        Next DD
        For CC = BB To UBound(OutArr, 1)
            If InArr(Lrow, 1) = OutArr(CC, 1) And InArr(Lrow, 2) = OutArr(CC, 3) And InArr(Lrow, 3) = OutArr(CC, 4) And InArr(Lrow, 4) = OutArr(CC, 6) Then
                InArr(Lrow, 5) = Val(InArr(Lrow, 5)) + Val(OutArr(CC, 7))
                InArr(Lrow, 6) = Val(InArr(Lrow, 6)) + Val(OutArr(CC, 8))
                For DD = 1 To 8
                    OutArr(CC, DD) = ""
                Next DD
            End If
        Next CC
        Lrow = Lrow + 1
    End If
Next BB


Set Ran = otp.Range("A2:F" & Lrow)
Ran = InArr


End Sub

 

[Osvaldo Palmeiro]

The Tab "Output" contains only 12 rows ... ~~~> you mean 10 rows (?)

Feb 28, 2018 2222 XYZ 49183 $93,574 6.0 ~~~> maybe $93,575

Try:

Sub ReplicateAndSumData()
 Dim LR As Long, k As Long
  LR = Cells(Rows.Count, 1).End(3).Row
  Sheets("Output").[A:F] = ""
  Range("A1:H" & LR).Copy Sheets("Output").[A1]
  With Sheets("Output")
   .Range("B:B,E:E").Delete
    For k = LR To 3 Step -1
     If .Cells(k - 1, 1) = .Cells(k, 1) And .Cells(k - 1, 2) = .Cells(k, 2) And .Cells(k - 1, 3) = .Cells(k, 3) And .Cells(k - 1, 4) = .Cells(k, 4) Then
      .Cells(k - 1, 5) = .Cells(k - 1, 5) + .Cells(k, 5)
      .Cells(k - 1, 6) = .Cells(k - 1, 6) + .Cells(k, 6)
      .Rows(k).Delete
     End If
    Next k
  End With
End Sub

 

[chillinsf49]

Hello RSpin,

First of all, I would like to say a "BIG THANK YOU!" for creating this code to me so quickly!

I tested it in my workbook and everything worked except the field names did not work properly. For the six fields that are supposed to copy over to Tab "Output": Date, Dept ID, Unit, Acct Num, Expense, HC, everything worked, except the field names for "Expense" and "HC" showed the number "0". What I would like to see is as the field names are: Date, Dept ID, Unit, Acct Num, Expense, HC; however, the output showed Date, Dept ID, Unit, Acct Num, 0, 0.

Would you mind pointing out to me which part of the code needs to be tweaked?

Thanks much!

 

[chillinsf49]

Hello Osvaldo,

Thank you for providing the code and pointing out the number of rows in the Tab "Output". Yes, the output should only include 10 rows of data. I accidentally provided the number of rows based on the last row with data shown in Excel (I accidentally included the first blank row and the second row which contains the field names.

I tried the code that you provided and ran into some issues:
1. The original data is in Tab "Data". The final results should populate Tab "Output". The code assumes the original data and final results are in the same Tab "Output".
2. The final results did not show the data in the other fields and field names: Date, Dept ID, Unit, Acct Num (these four columns were blank). The field names for "Expense" and "FTE" are shown, however, it shows the grand total for each one, $96,050 for Expense and 13.0 for FTE. What I would like to see is everything in the six fields and, where there are duplicate rows, sum them, and remove the duplicates (resulting in 10 rows.
3. I got an error on this line and didn't know what caused it:
.Cells(k - 1, 5) = .Cells(k - 1, 5) + .Cells(k, 5)

Thanks for your help!

 

[Osvaldo Palmeiro]

Hello Osvaldo,

1. The original data is in Tab "Data". The final results should populate Tab "Output". The code assumes the original data and final results are in the same Tab "Output".

Hi.
Sorry, I didn't say it before, but it's supposed that as you run the code the sheet "Data" should be the active sheet.

 

[chillinsf49]

Osvaldo,

Thank you so much! This worked!

 

[RSpin]

First, my apologies for the late reply, I've been dealing with some Real Life issues lately. I don't know if you're still interested, as it sounds like Osvaldo was able to help you, but here some code to fix the issue with the code I provided:

otp.range("A1") = dta.range("A1")
otp.range("B1") = dta.range("C1")
otp.range("C1") = dta.range("D1")
otp.range("D1") = dta.range("F1")
otp.range("E1") = dta.range("G1")
otp.range("F1") = dta.range("H1")

just put this at the end before "end sub" and it should work fine.

 

[chillinsf49]

RSpin,

Thanks for getting back to me with the add'l code to fix the issue. This also worked!

Hope everything is back to normal for you now. Happy Holidays!