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

chillinsf49

New Member
Joined
Dec 15, 2018
Messages
11
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
DateProgramDept IDUnitAcct Level 1Acct NumExpenseHC
Jan 31, 2018Technology1111ABCEmp Related24353$54-
Jan 31, 2018Technology1111ABCPostage/Courier Service79810$81-
Jan 31, 2018Technology1111ABCTravel and Other80545$77-
Jan 31, 2018Technology1111XYZTravel87342($2,991)2.0
Jan 31, 2018Technology1111XYZTravel87342$05.0
Jan 31, 2018Technology1111EFGTravel and Misc80555$0-
Jan 31, 2018Technology1111ABCBonus21930$3,626-
Jan 31, 2018Technology1111EFGBonus21930$1,000-
Jan 31, 2018Technology1111EFGBonus97897$594-
Feb 28, 2018Technology2222XYZManagement & Supervision49183$81,6885.0
Feb 28, 2018Technology2222XYZManagement & Supervision49183$11,8871.0
Feb 28, 2018Technology2222ABCHousekeeping Supply53421$34-

<tbody>
</tbody>


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 -
 

Excel Facts

What is the shortcut key for Format Selection?
Ctrl+1 (the number one) will open the Format dialog for whatever is selected.
I believe this does what you are looking for:

Code:
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
 
Upvote 0
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:
Code:
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
 
Upvote 0
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!
 
Upvote 0
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!
 
Upvote 0
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.
 
Upvote 0
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:
Code:
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.
 
Upvote 0
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!
 
Upvote 0

Forum statistics

Threads
1,213,527
Messages
6,114,142
Members
448,551
Latest member
Sienna de Souza

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top