Efficiency Suggestions for this piece of Excel VBA? 2

[VBAjedi]

Hi all!

I would appreciate any suggestions on how to speed up the following piece of code. The code processes a data sheet against a log sheet. Essentially, for each data row (there's about 7000 of them), it looks for a matching key value in the log sheet (which currently has about 8000 rows). When a log match is found, it updates the log row with the values from the data sheet row.

The code currently takes an eternal 15 minutes to run. Here's the whole sub, but I'm primarily interested in speeding up the find/write loop:

Sub UpdateSummaryStats()
Dim x, y, z, a, b
Dim shSS As Object, shDA As Object
Dim LastSummaryRow As Integer, LastDataRow As Integer
Dim match As Object
Dim NewRecordsCounter As Integer

a = MsgBox("NOTE: This routine takes about two minutes " _
    & "per thousand data rows to run (i.e. 7000 rows " _
    & "would take about 15 minutes). Excel will be " _
    & "unavailable during this time. Continue?", vbOKCancel)
If a = 2 Then Exit Sub

Set shSS = Sheets("Summary Stats")
Set shDA = Sheets("DATA")
shDA.Activate
NewRecordsCounter = 0

x = RotateWeeksData()

' Find LastDataRow and LastSummaryRow
For x = 3 To 50000
    If Len(shDA.Range("I" & x).Value) = 0 And _
        Len(shDA.Range("F" & x).Value) = 0 Then
        ' No doc # or cust ID
        GoTo LastDataRowFound:
    End If
Next x
LastDataRowFound:
LastDataRow = x - 1

For x = 13 To 50000
    If Len(shSS.Range("I" & x).Value) = 0 And _
        Len(shSS.Range("F" & x).Value) = 0 Then
        ' No doc # or cust ID
        GoTo LastSummaryRowFound:
    End If
Next x
LastSummaryRowFound:
LastSummaryRow = x - 1

' USE FIND FUNCTION TO LOCATE MATCHING SUMMARY ROW FOR
' EACH DATA ROW
a = Now
For x = 3 To LastDataRow
    With shSS.Range("I13:I" & LastSummaryRow)
        Set match = .Find(shDA.Range("I" & x).Value)
        If Not match Is Nothing Then
            y = match.row
            GoTo MatchFound:
        Else
            GoTo NoMatch:
        End If
    End With
NoMatch:
    NewRecordsCounter = NewRecordsCounter + 1
    LastSummaryRow = LastSummaryRow + 1
    y = LastSummaryRow
    shSS.Range("V" & y).Value = "New This Week"
MatchFound:
    shSS.Range("A" & y).Value = shDA.Range("A" & x).Value
    shSS.Range("B" & y).Value = shDA.Range("B" & x).Value
    shSS.Range("C" & y).Value = shDA.Range("C" & x).Value
    shSS.Range("D" & y).Value = shDA.Range("D" & x).Value
    shSS.Range("E" & y).Value = shDA.Range("E" & x).Value
    shSS.Range("F" & y).Value = shDA.Range("F" & x).Value
    shSS.Range("G" & y).Value = shDA.Range("G" & x).Value
    shSS.Range("H" & y).Value = shDA.Range("H" & x).Value
    shSS.Range("I" & y).Value = shDA.Range("I" & x).Value
    shSS.Range("J" & y).Value = shDA.Range("J" & x).Value
    shSS.Range("K" & y).Value = shDA.Range("K" & x).Value
    shSS.Range("L" & y).Value = shDA.Range("L" & x).Value
    shSS.Range("M" & y).Value = shDA.Range("M" & x).Value
    shSS.Range("N" & y).Value = shDA.Range("N" & x).Value
    shSS.Range("O" & y).Value = shDA.Range("O" & x).Value
    shSS.Range("P" & y).Value = shDA.Range("P" & x).Value
    shSS.Range("Q" & y).Value = shDA.Range("Q" & x).Value
    shSS.Range("R" & y).Value = shDA.Range("R" & x).Value
    shSS.Range("S" & y).Value = shDA.Range("S" & x).Value
    shSS.Range("T" & y).Value = shDA.Range("T" & x).Value
    shSS.Range("U" & y).Value = shDA.Range("U" & x).Value
    shDA.Range("A1").Value = x ' provides visual progress
        ' indicator, doesn't seem to affect speed much
    
NextX:

Next x
MsgBox ("Successfully updated the Summary Sheet. " _
    & NewRecordsCounter & " new records added.")
End Sub

Thanks in advance for any suggestions!

VBAjedi

 

[slreynolds]

This applications seems to be screaming to be made into a database. Is there a reason it needs to stay in Excel?

Susan

 

[Zathras]

I want to take a detailed look at this, but first you can get some immediate improvement by not using Variant data types for loop counters.

I.e., instead of

   Dim x, y, z, a, b

which makes them all Variant type, change to

   Dim x as long, y as long, z as long, a as long, b as long

Or, if you prefer, you can do it this way:

   Dim x&, y&, z&, a&, b&

 

[RobBroekhuis]

For the benefit of those who need to understand the code - get rid of all the goto's. Each one of them can be replaced by a do..loop or block if..then..else..endif structure, for much greater legibility. I would also guess that it's somewhat faster to use
cells(x,1)
instead of
range("A" & x)
even though I haven't tested this. Actually, you can replace all the assigments with a copy statement:

shSS.Range("A" & y & ":U" & y).copy shDA.cells(x,1)

Use the timer function to find out which part of your macro is taking the longest, and to note which changes improve things and which don't.
Rob

 

[VBAjedi]

Susan:
Yes, moving this to a dbase would undoubtedly make this task faster. However, I specialize in providing solutions to companies that are willing to sacrifice seconds (or even minutes) of processing time in exchange for having all of their data immediately accessible to anyone with a working knowledge of Excel (it's a rather interesting niche!). In this case, the 15 minute job only has to be run once a week at most. Once the data is in, the rest of my workbook is quite fast.

Zathras:
Thanks for the tip. Any others will be appreciated as well!

VBAjedi

 

[VBAjedi]

Rob,

Initial tests of Zathras' and your suggested tweaks show significant improvement. Stars around.

I've never seen copy used in that way before - that's pretty slick. That's the kind of thing ripping recorder code won't teach you! I assume that what you actually meant was:

shDA.Range("A" & x & ":U" & x).Copy shSS.Cells(y, 1)

My individual-cell copy approach was a holdover from a data source that had the columns in the wrong order (since fixed). It hadn't occured to me that I could change that now.

And I have been using the timer as you suggested (I just stripped it out of my example).

I know, I know - Goto's are hard to follow. They are a bad habit from before I knew better.

Thanks for the input!

VBAjedi

 

[RobBroekhuis]

Yes, of course, I got the source and destination mixed up. Luckily you knew better
Rob

 

[Zathras]

Here is a version that is functionally equavalent to the posted code. By revising some techniques and removing the display in A1 it processes all 7,000 rows of data in 2 minutes and 20 seconds on my AMD K6-2 which is running at about 450Mhz:

(If you leave the "A1" display in, it processes about 1,400 rows per minute.)

Option Explicit
Const COL_DOCNUM = 9
Const COL_CUSTID = 6

Sub UpdateSummaryStats()
Dim x&, y& ', z&, a, b  (vars not used)
Dim shSS As Worksheet, shDA As Worksheet  ' change from object
Dim LastSummaryRow As Integer, LastDataRow As Integer  's/b long
Dim c As Range
Dim SummaryRange As Range
Dim DataRange As Range
Dim match As Range  ' not Object
Dim NewRecordsCounter As Integer

'a = MsgBox("NOTE: This routine takes about two minutes " _
'    & "per thousand data rows to run (i.e. 7000 rows " _
'    & "would take about 15 minutes). Excel will be " _
'    & "unavailable during this time. Continue?", vbOKCancel)
'If a = 2 Then Exit Sub

Set shSS = Sheets("Summary Stats")
Set shDA = Sheets("DATA")

shDA.Activate
NewRecordsCounter = 0

x = RotateWeeksData()

' Find LastDataRow and LastSummaryRow
  LastDataRow = shDA.Cells(65536, COL_DOCNUM).End(xlUp).Row
  x = shDA.Cells(65536, COL_CUSTID).End(xlUp).Row
  If x > LastDataRow Then LastDataRow = x
  If LastDataRow < 3 Then LastDataRow = 3

  LastSummaryRow = shSS.Cells(65536, COL_DOCNUM).End(xlUp).Row
  x = shSS.Cells(65536, COL_CUSTID).End(xlUp).Row
  If x > LastSummaryRow Then LastSummaryRow = x
  If LastSummaryRow < 13 Then LastSummaryRow = 13

' USE FIND FUNCTION TO LOCATE MATCHING SUMMARY ROW FOR
' EACH DATA ROW

  Set DataRange = shDA.Range(&quot;I3:I&quot; & LastDataRow)
  Set SummaryRange = shSS.Range(&quot;I13:I&quot; & LastSummaryRow)
  
  Application.ScreenUpdating = False

  For Each c In DataRange
    Set match = SummaryRange.Find(c.Value)
    If match Is Nothing Then
      ' New this week
      NewRecordsCounter = NewRecordsCounter + 1
      LastSummaryRow = LastSummaryRow + 1
      y = LastSummaryRow
      shSS.Range(&quot;V&quot; & LastSummaryRow).Value = &quot;New This Week&quot;
      Set SummaryRange = shSS.Range(&quot;I13:I&quot; & LastSummaryRow)
    Else
      ' Update
      y = match.Row
    End If
    
    ' Update or insert
    UpdateSummary shSS, y, shDA, c.Row
  Next c
  
  Application.ScreenUpdating = True

  Set shDA = Nothing
  Set shSS = Nothing
  Set SummaryRange = Nothing
  Set DataRange = Nothing
  Set match = Nothing

  MsgBox (&quot;Successfully updated the Summary Sheet. &quot; _
      & NewRecordsCounter & &quot; new records added.&quot;)
End Sub

Sub UpdateSummary(SSheet As Worksheet, SRow As Long, _
                              DSheet As Worksheet, DRow As Long)
  DSheet.Range(&quot;A&quot; & DRow & &quot;:U&quot; & DRow).Copy
  SSheet.Range(&quot;A&quot; & SRow & &quot;:U&quot; & SRow).PasteSpecial xlPasteAll
  Application.CutCopyMode = False
End Sub

 

[RobBroekhuis]

If you need progress update, it's probably faster to put it either in the status bar or on a userform.
Rob

 

[VBAjedi]

Zathras:

Your code was a nice surprise to have waiting for me at the office on Monday morning! With my live data on my PC, it ran in about seven minutes (half what the original code took!). A star for your cut-and-paste ready contribution.

Rob:

Writing to the status bar doesn't seem to slow it down at all! I used:

Application.StatusBar = "Now processing data row: " & MyRow

A star for that excellent tip. I'll use that often in the future.

Thanks again, all!

VBAjedi

 

[Zathras]

VBAJedi, happy to be of service.

Be sure to add this at the end of your code to tell Excel when you are longer updating the status line:

   Application.StatusBar = False