Excel Macro - Speed increase suggestions needed.

[Spy128Bit]

The following macro works but against 30,000 rows it just isn't time
efficient. I tried to have it reset the last row each loop in an
attempt to speed it up but it had little impact. My concern is over
the array being 120 elements but I don't know much about them so that
could be the problem. Please let me know if you have any ideas or
suggestions.

Sub Auto_Combine()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
LRow = Cells(Rows.Count, "A").End(xlUp).Row
Dim ActArray As Variant
ActArray = Array("P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y",
"Z", "AA", "AB", "AC", "AD", "AE", "AF", "AG", "AH", "AI", "AJ", "AI",
"AJ", "AK", "AL", "AM", "AN", "AO", "AP", "AQ", "AR", "AS", "AT",
"AU", "AV", "AW", "AX", "AY", "AZ", "BA", "BB", "BC", "BD", "BE",
"BF", "BG", "BH", "BI", "BJ", "BK", "BL", "BM", "BN", "BO", "BP",
"BQ", "BR", "BS", "BT", "BU", "BV", "BW", "BX", "BY", "BZ", "CA",
"CB", "CC", "CD", "CE", "CF", "CG", "CH", "CI", "CJ", "CK", "CL",
"CM", "CN", "CO", "CP", "CQ", "CR", "CS", "CT", "CU", "CV", "CW",
"CX", "CY", "CZ", "DA", "DB", "DC", "DD", "DE", "DF", "DG", "DH",
"DI", "DJ", "DK", "DL", "DM", "DN", "DO", "DP", "DQ", "DR", "DS",
"DT", "DU", "DV", "DW", "DX", "DY", "DZ", "EA", "EB", "EC", "ED")
For Z = 2 To LRow
RowCk:
If Range("A" & Z) = Range("A" & (Z - 1)) And Range("G" & Z) =
Range("G" & (Z - 1)) Then
Rows(Z).Delete
GoTo RowCk:
End If
Reset_LastCell
LRow = Cells(Rows.Count, "A").End(xlUp).Row
For A = 0 To UBound(ActArray)
Range("" & ActArray(A) & Z & "") = Application.Evaluate("SUMPRODUCT(--
($A$2:$A$" & LRow & "=$A" & Z & "),--($G$2:$G$" & LRow & "=$G" & Z &
"),--($J$2:$J$" & LRow & "=" & ActArray(A) & "1" & "),$O$2:$O$" & LRow
& ")")
Next
Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

 

[Guest]

I notice that you mean to have a consecutive range in your array. To make
the code more readable, consider using a Range object:

dim myRange as Range
set myRange = ActiveSheet.Range("P:ED")

The above example sets a range object equal to all the columns. You could
use "P1:ED1" to make a smaller range. Then, use something like

For Each cell in myRange
cells(Z,cell.column) = application.evaluate....
Next cell

I am guessing that the code is slow because you are deleting rows (with lots
of columns) within a loop. The spreadsheet has to update itself everytime
this happens, whether or not ScreenUpdating is on. I ran into this problem
once last year.

I found a huge speed increase when I deleted a value from a column
guaranteed to have a value. Then, at the end of processing, I selected that
column, used SpecialCells to select all blank cells, and
Selection.EntireRow.Delete. Then, the sheet has to reformat only once. I
found this method increased speed by minutes.

Here's an example in a single line of code!
Range("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete

That's pretty efficient! If you aren't sure there will be a reliable data
column, create a dummy column with dummy values to delete. This is also fast
and simple.

This method adds a few more steps to the code, but you avoid the possibility
of deleting several thousand rows one at a time.

By the way, I am confused by your SUMPRODUCT formula. What are you trying
to do? Are you testing to see whether the column's product equals the
current cell? Please explain.

Please let me know if this works for you.

HTH,
Pflugs

 

[Spy128Bit]

I didn't realize I could use the column reference only without a row
included. I've included the updated one I am currently using.

The purpose of the macro is to turn:
Name Activity Total
John 1 15
John 2 30

Into:
Name 1 2
John 15 30

I wanted to make one line per person per day and give the totals for
each activity in one line rather than 30,000. It has improved
slightly with the changes I made but it just seems like there's a more
efficient way to get the results I'm looking for that maybe I just
don't see. I'm trying to use your suggestions now and will see how it
changes afterwards. If you need any more information, just let me
know. Thanks for helping out.

Sub Working()
Dim A, Y, Z As Integer
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
LRow = Cells(Rows.Count, "A").End(xlUp).Row
Dim ActArray As Variant
ActArray = Array("P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y",
"Z", "AA", "AB", "AC", "AD", "AE", "AF", "AG", "AH", "AI", "AJ", "AI",
"AJ", "AK", "AL", "AM", "AN", "AO", "AP", "AQ", "AR", "AS", "AT",
"AU", "AV", "AW", "AX", "AY", "AZ", "BA", "BB", "BC", "BD", "BE",
"BF", "BG", "BH", "BI", "BJ", "BK", "BL", "BM", "BN", "BO", "BP",
"BQ", "BR", "BS", "BT", "BU", "BV", "BW", "BX", "BY", "BZ", "CA",
"CB", "CC", "CD", "CE", "CF", "CG", "CH", "CI", "CJ", "CK", "CL",
"CM", "CN", "CO", "CP", "CQ", "CR", "CS", "CT", "CU", "CV", "CW",
"CX", "CY", "CZ", "DA", "DB", "DC", "DD", "DE", "DF", "DG", "DH",
"DI", "DJ", "DK", "DL", "DM", "DN", "DO", "DP", "DQ", "DR", "DS",
"DT", "DU", "DV", "DW", "DX", "DY", "DZ", "EA", "EB", "EC", "ED")
Y = 2
For Z = 2 To LRow
Selection.AutoFilter Field:=1, Criteria1:=Range("A" & Z)
RowCk:
If Range("A" & Z) > "" And Range("A" & Z) = Range("A" & (Z - 1)) And
Range("G" & Z) = Range("G" & (Z - 1)) Then
Rows(Z).Delete
Y = Z
GoTo RowCk:
End If
Reset_LastCell
LRow = Cells(Rows.Count, "A").End(xlUp).Row
For A = 0 To UBound(ActArray)
Range("" & ActArray(A) & Z & "") = Application.Evaluate("SUMPRODUCT(--
($A$" & Y & ":$A$" & LRow & "=$A" & Z & "),--($G$" & Y & ":$G$" & LRow
& "=$G" & Z & "),--($J$" & Y & ":$J$" & LRow & "=" & ActArray(A) & "1"
& "),$O$" & Y & ":$O$" & LRow & ")")
Next
Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub