×
INTELLIGENT WORK FORUMS
FOR ENGINEERING PROFESSIONALS

Log In

Come Join Us!

Are you an
Engineering professional?
Join Eng-Tips Forums!
  • Talk With Other Members
  • Be Notified Of Responses
    To Your Posts
  • Keyword Search
  • One-Click Access To Your
    Favorite Forums
  • Automated Signatures
    On Your Posts
  • Best Of All, It's Free!

*Eng-Tips's functionality depends on members receiving e-mail. By joining you are opting in to receive e-mail.

Posting Guidelines

Promoting, selling, recruiting, coursework and thesis posting is forbidden.

Students Click Here

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

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.

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

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

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

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

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

(OP)
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...

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 Sub 

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

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:

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

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

Thinking through this some more, it occurred to me that this is an ideal application for the scripting dictionary object; see:
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 Function 

The scripting dictionary does the job in 0.75 seconds.

Not too bad :)

Doug Jenkins
Interactive Design Services
http://newtonexcelbach.wordpress.com/

Red Flag This Post

Please let us know here why this post is inappropriate. Reasons such as off-topic, duplicates, flames, illegal, vulgar, or students posting their homework.

Red Flag Submitted

Thank you for helping keep Eng-Tips Forums free from inappropriate posts.
The Eng-Tips staff will check this out and take appropriate action.

Reply To This Thread

Posting in the Eng-Tips forums is a member-only feature.

Click Here to join Eng-Tips and talk with other members! Already a Member? Login


Resources

White Paper - Reshoring Prototyping and Production
In this whitepaper, we'll provide insight into why and when it makes sense for U.S. manufacturers to reshore prototyping and production, and how companies can leverage the benefits of working with local design, prototype, and manufacturing partners during the pandemic and beyond. Download Now
Engineering Report - Top 10 Defect Types in Production
This 22-page report from Instrumental identifies the most common production defect types discovered in 2020, showcases trends from 2019 to 2020, and provides insights on how to prevent potential downtime in 2021. Unlike other methods, Instrumental drives correlations between a variety of data sources to help engineers find and fix root causes. Download Now
White Paper - Addressing Tooling and Casting Requirements at the Design Stage
Several of the tooling and casting requirements of a part can be addressed at the design stage. If these requirements are not addressed at the design stage, lot of time is spent in design iteration when the design reaches the die caster. These design issues lead to increase in time and cost of production leading to delay in time to market and reduced profits for the organization. Download Now

Close Box

Join Eng-Tips® Today!

Join your peers on the Internet's largest technical engineering professional community.
It's easy to join and it's free.

Here's Why Members Love Eng-Tips Forums:

Register now while it's still free!

Already a member? Close this window and log in.

Join Us             Close