VBA - sum cells that match criteria and copy rows to different sheet

[justhumm]

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.

''--------------------------------------------------------------------------------
'' 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

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

 

[IDS]

I have set up a user defined function that sums the matching rows:

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 Function

This 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:

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 Sub

This requires three named ranges:
TLD : 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/

 

[justhumm]

I actually got the VBA up and running. It seems to be working the way I want it to...

Thanks a lot for posting. I'll have to compare and contrast...

''--------------------------------------------------------------------------------
'' 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 Sub

 

[IDS]

Checking my code with a bigger data range I found it only worked because the number of rows in the original data was the same as the number of columns.

That can be fixed by changing NumRows to NumCols as below:

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

Comparing 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/

 

[IDS]

Thinking through this some more, it occurred to me that this is an ideal application for the scripting dictionary object; see:

http://newtonexcelbach.wordpress.co...ith-fem-data-and-using-the-dictionary-object/

Note that you need to add a reference to Microsoft Scripting Runtime under Tools-References in the VB editor.

Here's the new code:

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 Function

The scripting dictionary does the job in 0.75 seconds.

Not too bad

Doug Jenkins
Interactive Design Services

http://newtonexcelbach.wordpress.com/