VBA - sum cells that match criteria and copy rows to different sheet
VBA - sum cells that match criteria and copy rows to different sheet
(OP)
I have a worksheet with raw output data from another program. I want to look through the worksheet, sum certain cells within rows that match criteria (which is based on other cells), and copy those summed rows to another worksheet.
I'm posting the pseudocode (as I see it in my mind) and my first attempt at the VBA code. The first reported bug is in the "k" loop, but I'm sure there are other problems as well.
I hope I have made myself somewhat clear; and if someone could give me some feedback and possible corrections, I would really appreciate it.
Cheers.
I'm posting the pseudocode (as I see it in my mind) and my first attempt at the VBA code. The first reported bug is in the "k" loop, but I'm sure there are other problems as well.
I hope I have made myself somewhat clear; and if someone could give me some feedback and possible corrections, I would really appreciate it.
Cheers.
CODE -->
''--------------------------------------------------------------------------------
'' PSEUDOCODE FOR MACRO
''--------------------------------------------------------------------------------
''
'Sub Name()
'
'' Declare Variables
''
'worksheet1 = raw source data (60K rows, 13 columns of data)
'worksheet2 = resulting processed data (40k rows, 13 columns of data)
'array1 = temp storage array (40k rows, 13 columns of data)
'array2 = temp starage array (20k rows, 13 columns of data)
'criteria1 = lookup value used to find rows that are placed in array1
'criteria2 = lookup value used to find rows that are placed in array1
'i = index number of the first data row in worksheet 1
'j = index number of the column that will be compared to criteria
'k = index number of the first row in array
'm = index number of the column that will be compared to in array
'n = index number of the column that will be compared to in array
'
'clear out a range of cells in worksheet2
'
'Begin creating temporary arrays
'
'For each row in worksheet1,
' If the value in column "j" = criteria1,
' Then copy that row to array1
'
' Else If the value in column "j" = criteria2,
' Then copy that row to array2
'
' Next row, until end of data range in worksheet1...
'End creation of temporary arrays
'
'Begin adding matching rows in temporary arrays
'
'For each row in array1,
' For each row in array2,
' If array1(column "m") = array2(column "m")
' AND array1(column "n") = array2(column "n")
'
' Then sum array1(columns "m-6" thru "m-1") [where "m-1" is meant as a relative position]
' ...array1(column "m-6") = array1(column "m-6") + array2(column "m-6")
' ...array1(column "m-5") = array1(column "m-5") + array2(column "m-5")
' ...array1(column "m-4") = array1(column "m-4") + array2(column "m-4")
' ...etc.
'
' Next row, until end of data range in array2
' Next row, until end of data range in array1
'End adding matching rows in temporary arrays
'
'Copy & Paste array1 into worksheet2(beginning at row "i", column 1)
'
'End Sub
'--------------------------------------------------------------------------------
'--------------------------------------------------------------------------------
' -------------------------
' BADLY CODED VBA FOR MACRO
' -------------------------
Sub matchandadd()
Application.ScreenUpdating = False
Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets("worksheet1")
Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Sheets("worksheet2")
Dim array1 As Variant
Dim array2 As Variant
Dim criteria1 As String
Dim criteria2 As String
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim m As Integer
Dim n As Integer
criteria1 = "LinStatic"
criteria2 = "LinMoving"
i = 15 ' index number of the first data row in worksheet 1
j = 4 ' index number of the column that will be compared to criteria
m = 12 ' index number of the column that will be compared to in array
n = 13 ' index number of the column that will be compared to in array
ws2.Range(Cells(i, "A"), "M65536").Clear ' make sure destination cells are empty
For i = i To ws1.Range("M65536").End(xlUp).Row
If ws1.Cells(i, j) = criteria1 _
Then ws1.Rows(i).Copy array1.Rows(array1.Cells(array1.Rows.Count, "A").End(xlUp).Row + 1)
If ws1.Cells(i, j) = criteria2 _
Then ws1.Rows(i).Copy array2.Rows(array2.Cells(array2.Rows.Count, "A").End(xlUp).Row + 1)
Next i
For k = 1 To array1.Rows.Count.End(xlUp).Row
If array1.Cells(k, m) = array2.Cells(k, m) _
And array1.Cells(k, n) = array2.Cells(k, n) _
Then (array1.Range(cells(k, m-6):cells(k, m-1)) = _
array1.Range(cells(k, m-6):cells(k, m-1)) + array2.Range(cells(k, m-6):cells(k, m-1))).Row + 1
Next k
array1.Copy ws2.Rows(i)
Application.ScreenUpdating = True
End Sub CODE -->
Frame Station OutputCase CaseType StepType P V2 V3 T M2 M3 FrameElem ElemStation BNA1 0.75 DC LinStatic 2.007 -11.202 1.245 -6.739 -1.916 -4.7053 BNA1-1 0.75 BNA1 2.4445 DC LinStatic 2.007 -9.804 1.245 -6.739 -4.0256 13.0921 BNA1-1 2.4445 BNA1 2.4445 DC LinStatic 10.401 -6.28 0.263 -2.7861 -1.3307 0.7231 BNA1-2 0 BNA1 3.6667 DC LinStatic 10.401 -5.271 0.263 -2.7861 -1.6522 7.7821 BNA1-2 1.2222 BNA1 4.889 DC LinStatic 10.401 -4.263 0.263 -2.7861 -1.9736 13.6086 BNA1-2 2.4445 BNA1 0.75 HL case LinMoving Max P 13.04 0.669 -9.366 6.6785 -15.74 9.3092 BNA1-1 0.75 BNA1 2.4445 HL case LinMoving Max P 13.04 0.669 -9.366 6.6785 0.1214 8.175 BNA1-1 2.4445 BNA1 2.4445 HL case LinMoving Max P 14.937 -2.239 -3.737 6.5927 -5.4166 5.1967 BNA1-2 0 BNA1 3.6667 HL case LinMoving Max P 14.937 -2.239 -3.737 6.5927 -0.8486 7.9331 BNA1-2 1.2222 BNA1 4.889 HL case LinMoving Max P 14.937 -2.239 -3.737 6.5927 3.7193 10.6696 BNA1-2 2.4445 BNA1 4.889 HL case LinMoving Max P 17.793 -1.989 -2.26 5.8633 -1.2305 6.3499 BNA1-3 0 BNA1 6.1112 HL case LinMoving Max P 17.793 -1.989 -2.26 5.8633 1.5311 8.7814 BNA1-3 1.2222 BNA1 7.3335 HL case LinMoving Max P 17.793 -1.989 -2.26 5.8633 4.2928 11.213 BNA1-3 2.4445





RE: VBA - sum cells that match criteria and copy rows to different sheet
CODE --> VB
Function SumSelect(CopyRange As Variant, Criteria As Variant, Optional OutRows As Long) As Variant Dim NumRows As Long, NumCols As Long, CCol1 As Long, CCol2 As Long, CCol3 As Long Dim TempA1() As Variant, TempA2() As Variant Dim Criteria1 As String, Criteria2 As String, TA1Rows As Long, TA2Rows As Long Dim i As Long, j As Long, k As Long, m As Long, n As Long ' Convert ranges into arrays If TypeName(CopyRange) = "Range" Then CopyRange = CopyRange.Value2 If TypeName(Criteria) = "Range" Then Criteria = Criteria.Value2 NumRows = UBound(CopyRange) NumCols = UBound(CopyRange, 2) ReDim TempA1(1 To NumRows, 1 To NumCols) ReDim TempA2(1 To NumRows, 1 To NumCols) ' Read Criteria columns and text CCol1 = Criteria(1, 1) CCol2 = Criteria(2, 1) CCol3 = Criteria(3, 1) Criteria1 = Criteria(4, 1) Criteria2 = Criteria(5, 1) ' Copy rows matching criteria to arrays TempA1 and TempA2 k = 0 m = 0 For i = 1 To NumRows If CopyRange(i, CCol1) = Criteria1 Then k = k + 1 For j = 1 To NumRows TempA1(k, j) = CopyRange(i, j) Next j ElseIf CopyRange(i, CCol1) = Criteria2 Then m = m + 1 For j = 1 To NumRows TempA2(m, j) = CopyRange(i, j) Next j End If Next i TA1Rows = k TA2Rows = m ' Sum Matching rows in TempA1 For i = 1 To TA1Rows For j = 1 To TA2Rows If TempA1(i, CCol2) = TempA2(j, CCol2) And TempA1(i, CCol3) = TempA2(j, CCol3) Then For n = 1 To 6 TempA1(i, CCol2 - n) = TempA1(i, CCol2 - n) + TempA2(j, CCol2 - n) Next n End If Next j Next i OutRows = TA1Rows SumSelect = TempA1 End FunctionThis could be used directly on the spreadsheet by entering as an array function:
=Sumselect(Sheet1!A15:M27,Criteria)
where the first range is the data, and Criteria is a single column range with the values 4, 12, 13, LinStatic, Linmoving
Enter with Ctrl-Shift-Enter to return all the output data.
The function can be combined with a simple Sub to automate the process:
CODE --> VB
Sub CopySum() Dim DataRange As Variant, Criteria As Variant, ResA As Variant, ResRange As Range, TLD As Range Dim OutRows As Long Const OutCols As Long = 13 Set TLD = Range("TLData") Set DataRange = Range(TLD, TLD.SpecialCells(xlLastCell)) Set Criteria = Range("Criteria") Set ResRange = Range("Results") ResA = SumSelect(DataRange, Criteria, OutRows) ResRange.ClearContents ResRange.Resize(OutRows, OutCols).Name = "Results" ResRange.Value2 = ResA End SubTLD : The top left cell of the input data range.
Criteria: A five row range with the criteria values as listed above
Results : The results range. For the first use it can be any size, as long as the top-left cell is where you want it.
The main difference from the original code is that I have converted the input and working data ranges to arrays, which will be much quicker, and are easier to work with.
The spreadsheet is attached below. Note that it returns results, but I haven't checked them!
Doug Jenkins
Interactive Design Services
http://newtonexcelbach.wordpress.com/
RE: VBA - sum cells that match criteria and copy rows to different sheet
Thanks a lot for posting. I'll have to compare and contrast...
CODE --> VBA
''-------------------------------------------------------------------------------- '' PSEUDOCODE FOR MACRO ''-------------------------------------------------------------------------------- 'The VBA subroutine filters through a table of data and splits it into 2 arrays '(originally from SAP2000), based on user-defined criteria contained in one of the columns. 'It then adds together certain cells from matching rows in the two arrays. ' 'Sub Name() ' 'Declare Variables and enter user-defined values ' 'The user pastes raw data into worksheet1 'clear out a range of cells in worksheet2, where ' ' 'Count the number of data rows that match criteria 1 'Count the number of data rows that match criteria 2 'Redimension each array according to the counted rows ' ' 'Begin loop to split table up into arrays 'For each row in worksheet1, ' If the value in the criteria column = criteria1, ' Then ' Begin a sub-loop to insert each cell in the row into array1 ' Else If the value in the criteria column = criteria2, ' Then ' Begin a sub-loop to insert each cell in the row into array2 'Next row, until end of data range in worksheet1... ' ' 'Begin loop add together matching array rows 'For each row in array1, ' Begin a sub-loop to compare the row in array1 to each row in array2 ' For each row in array2 ' If the the specified column matches for array1 & array2 ' And the specified second column matches for array1 & array2 ' Then ' Begin a sub-sub-loop to add applicable cells in the row from array 2 into array1 'Next row, until end of array1 ' ' 'Set range of cells in worksheet2 = array1 ' ' 'End Sub '-------------------------------------------------------------------------------- '-------------------------------------------------------------------------------- Option Explicit 'Requires that all variables be defined Sub MatchAndAdd() Application.ScreenUpdating = False Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets("worksheet1") Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Sheets("worksheet2") Dim array1, array2, array3 As Variant Dim count1, count2, criteria1, criteria2 As String Dim lastrow, firstrow, lastcol As Integer Dim ColCrit0, ColComp1, ColComp2 As Integer Dim i, j, k, m, n, z As Integer Dim breakcheck1, breakcheck2, breakcheck3 As Variant criteria1 = "LinMoving" criteria2 = "LinStatic" firstrow = 15 ' index number of the first data row in worksheet 1 lastcol = 13 ' index number of the last column row in worksheet 1 ColCrit0 = 4 ' index number of the column that will be compared to criteria ColComp1 = 12 ' index number of the column that will be compared to in array ColComp2 = lastcol ' index number of the column that will be compared to in array ws2.Activate ws2.Range(Cells(firstrow, "A"), "M65536").Clear ' make sure destination cells are empty ws1.Activate lastrow = ws1.Cells(65536, 1).End(xlUp).Row ' this counts number of rows that contain data count1 = Application.WorksheetFunction.CountIf(ws1.Columns(ColCrit0), criteria1) count2 = Application.WorksheetFunction.CountIf(ws1.Columns(ColCrit0), criteria2) ReDim array1(1 To count1, 1 To lastcol) ReDim array2(1 To count2, 1 To lastcol) ReDim array3(1 To count2, 1 To lastcol) j = 0 'Initial Row Index in Array1 k = 1 'Initial Column Index in Worksheet1 m = 0 n = 1 For i = firstrow To lastrow If ws1.Cells(i, ColCrit0) = criteria1 Then j = j + 1 For k = 1 To lastcol array1(j, k) = ws1.Cells(i, k) Next k ElseIf ws1.Cells(i, ColCrit0) = criteria2 Then m = m + 1 For n = 1 To lastcol array2(m, n) = ws1.Cells(i, n) Next n End If Next i For i = 1 To count1 For j = 1 To count2 If array1(i, lastcol) = array2(j, lastcol) _ And array1(i, lastcol - 1) = array2(j, lastcol - 1) _ Then For k = lastcol - 7 To lastcol - 2 array1(i, k) = array1(i, k) + array2(j, k) Next k End If Next j Next i breakcheck1 = array1(1, 7) 'placeholder for checking a value when using "breakpoints" while debugging the VBA breakcheck2 = array2(10, 3) breakcheck3 = array3(10, 3) ws2.Activate ws2.Range(Cells(firstrow, "A"), Cells(-1 + firstrow + UBound(array1, 1), lastcol)) = array1 Application.ScreenUpdating = True End SubRE: VBA - sum cells that match criteria and copy rows to different sheet
That can be fixed by changing NumRows to NumCols as below:
CODE --> VBA
If CopyRange(i, CCol1) = Criteria1 Then k = k + 1 For j = 1 To NumCols TempA1(k, j) = CopyRange(i, j) Next j ElseIf CopyRange(i, CCol1) = Criteria2 Then m = m + 1 For j = 1 To NumCols TempA2(m, j) = CopyRange(i, j) Next j End IfComparing times with 53000 rows of data (just copying the original 13 rows) I get 245 seconds with my code and 650 seconds with yours. I'm actually surprised there is much difference now, because all the hard work is done comparing and operating on variant arrays, rather than ranges, in both cases.
Something you might look at is where you have a line like:
Dim lastrow, firstrow, lastcol As Integer
this creates lastrow and firstrow as variants, rather than integers. You have to call up each variable as the data type you want, otherwise they default to variant.
Also it's slightly quicker to use longs rather than integers (because integers get converted into longs anyway).
But I think the biggest speed improvement would come from sorting the data on Column 12, then breaking the loop as soon as the FrameElem values no longer matched. If this code is going to be used frequently doing that should reduce the run time down to a few seconds.
Doug Jenkins
Interactive Design Services
http://newtonexcelbach.wordpress.com/
RE: VBA - sum cells that match criteria and copy rows to different sheet
http://newtonexcelbach.wordpress.com/2010/09/26/wo...
Note that you need to add a reference to Microsoft Scripting Runtime under Tools-References in the VB editor.
Here's the new code:
CODE --> VBA
Function SumSelectD(CopyRange As Variant, Criteria As Variant, Optional OutRows As Long) As Variant Dim NumRows As Long, NumCols As Long, CCol1 As Long, CCol2 As Long, CCol3 As Long Dim TempA1() As Variant, TempA2() As Variant, A2Dict As Scripting.Dictionary Dim criteria1 As String, criteria2 As String, TA1Rows As Long, TA2Rows As Long, FrameRef As String Dim i As Long, j As Long, k As Long, m As Long, n As Long Set A2Dict = New Scripting.Dictionary ' Convert ranges into arrays If TypeName(CopyRange) = "Range" Then CopyRange = CopyRange.Value2 If TypeName(Criteria) = "Range" Then Criteria = Criteria.Value2 NumRows = UBound(CopyRange) NumCols = UBound(CopyRange, 2) ReDim TempA1(1 To NumRows, 1 To NumCols) ReDim TempA2(1 To NumRows, 1 To NumCols) ' Read Criteria columns and text CCol1 = Criteria(1, 1) CCol2 = Criteria(2, 1) CCol3 = Criteria(3, 1) criteria1 = Criteria(4, 1) criteria2 = Criteria(5, 1) ' Copy rows matching criteria to arrays TempA1 and TempA2 k = 0 m = 0 For i = 1 To NumRows If CopyRange(i, CCol1) = criteria1 Then k = k + 1 For j = 1 To NumCols TempA1(k, j) = CopyRange(i, j) Next j ElseIf CopyRange(i, CCol1) = criteria2 Then m = m + 1 For j = 1 To NumCols TempA2(m, j) = CopyRange(i, j) Next j End If Next i TA1Rows = k TA2Rows = m ' create A2Dict dictionary For i = 1 To TA2Rows FrameRef = TempA2(i, 12) & TempA2(i, 13) If A2Dict.Exists(Key:=FrameRef) = False Then A2Dict.Add FrameRef, i Else j = A2Dict.Item(FrameRef) For n = 1 To 6 TempA2(j, CCol2 - n) = TempA2(j, CCol2 - n) + TempA2(i, CCol2 - n) Next n End If Next i ' Sum Matching rows in TempA1 For i = 1 To TA1Rows FrameRef = TempA1(i, 12) & TempA1(i, 13) If A2Dict.Exists(Key:=FrameRef) = True Then j = A2Dict.Item(FrameRef) For n = 1 To 6 TempA1(i, CCol2 - n) = TempA1(i, CCol2 - n) + TempA2(j, CCol2 - n) Next n End If Next i OutRows = TA1Rows SumSelectD = TempA1 End FunctionThe scripting dictionary does the job in 0.75 seconds.
Not too bad :)
Doug Jenkins
Interactive Design Services
http://newtonexcelbach.wordpress.com/