0
\$\begingroup\$

I have been working on this particular sub for a while and it was very very slow from the beginning. Compared to my other subs that go through a lot more data the task of this one is almost minuscule. All it has to do is to go through about ~15 sheets and parse through a couple hundred cells. Since this is a fairly complicated task I need to test it a lot which becomes almost unbearable with how long it takes. I am not sure if there is anything I can do or if there even is a solution. I am open to all kinds of suggestions.

Private Sub CommandButton24_Click()

Dim xSheet As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim copyRng As Range
Dim destRng As Range
Dim cRange As Range
Dim c As Range
Dim uniqueVal() As Variant
Dim x As Long

With Application
    .ScreenUpdating = False
    .EnableEvents = False
End With

'Delete the summary worksheet if it exists.
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("Summary").Delete
On Error GoTo 0
Application.DisplayAlerts = True

' Add a worksheet with the name "Summary"
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "Summary"
DestSh.Range("A1").Value = "Account"
DestSh.Range("B1").Value = "Exchange"
DestSh.Range("C1").Value = "Quarter"
DestSh.Range("D1").Value = "Year"
Set destRng = DestSh.Range("E1")

'Define inital array values
uniqueVal = Array("Account by Type", "Total", "lv_nsac_ACCOUNT", "ams_ACCOUNT", "bru_ACCOUNT", "lsem_ACCOUNT", "mse_ACCOUNT", "par_ACCOUNT", "swx_ACCOUNT", "us_ACCOUNT", "wbag_ACCOUNT", "xetra_ACCOUNT", "europe_ACCOUNT", "lv_ACCOUNT", "lv_apac_ACCOUNT")

' This first part subtracts all the relevant column names, just running this
'already took excel about 3-5 minutes
' Loop through all worksheets and copy the data to the
' summary worksheet.
For Each xSheet In ActiveWorkbook.Worksheets

    If InStr(1, xSheet.Name, "ACCOUNT") And xSheet.Range("B1") <> "No Summary Available" Then _

        Set copyRng = xSheet.Range("A:A")

        For Each c In copyRng.SpecialCells(xlCellTypeVisible)

            If Len(c) <> 0 And Not ISIN(c, uniqueVal) Then _

                'Copy to destination Range
                c.Copy destRng
                'move destination Range
                Set destRng = destRng.Offset(0, 1)
                'change / adjust the size of array
                ReDim Preserve uniqueVal(0 To UBound(uniqueVal) + 1) As Variant
                'add value on the end of the array
                uniqueVal(UBound(uniqueVal)) = c.Value

            End If

        Next c

    End If

Next xSheet

'This second part is supposed to capture account names from the sheets and 
'and put them in the first column. The command has been running for 20 
'minutes with the program being completely non responsive.
'Loop through all worksheets and copy the data to the
'summary worksheet.
For Each xSheet In ActiveWorkbook.Worksheets

    If InStr(1, xSheet.Name, "ACCOUNT") And xSheet.Range("B1") <> "No Summary Available" Then _

        Set copyRng = xSheet.Cells

        For Each c In copyRng.SpecialCells(xlCellTypeVisible)

            If Len(c) <> 0 And Not ISIN(c, uniqueVal) Then _

                If InStr(1, c.Value, "C-") Then _

                'Set destination
                Set destRng = xSheet.Range("A2:A").Find(What:="*", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues)

                'Copy to destination Range
                c.Copy destRng

                End If

            End If

        Next c

    End If

Next xSheet

ExitTheSub:

Application.Goto DestSh.Cells(1)

With Application
    .ScreenUpdating = True
    .EnableEvents = True
End With


End Sub

Sorry for the massive block of code.

\$\endgroup\$
5
  • \$\begingroup\$ stackoverflow.com/q/7103552/1531971 might be related. \$\endgroup\$
    – jdv
    Aug 22 '17 at 14:56
  • \$\begingroup\$ @jdv That has to do with benchmarking code, not increasing the performance of the code. \$\endgroup\$ Aug 22 '17 at 17:45
  • \$\begingroup\$ Something odd in your workbook. The first part, which you say takes 3-5 minutes, should run in a fraction of a second. Perhaps try setting Calculation to Manual \$\endgroup\$ Aug 23 '17 at 0:12
  • \$\begingroup\$ @RonRosenfeld I will definitely do that. What exactly should I keep an eye out for? I am sorry if that questions seems weird, it's just that I am very new to VBA and I don't know what exactly is going to happen once I set calculation to manual. \$\endgroup\$
    – ShieldData
    Aug 23 '17 at 7:21
  • \$\begingroup\$ You would look for the code to speed up. But it seems I erred in my interpretation of which part took 3-5 minutes. I thought it was the segement ending with that comment; instead it was the part following that comment. \$\endgroup\$ Aug 23 '17 at 10:49
0
\$\begingroup\$

I have found the answer. What seems to have cause the issue is these lines of code:

Set copyRng = xSheet.Range("A:A")
Set copyRng = xSheet.Cells

All I wanted was to access the entire sheet with all of its non-empty cells. This seems to have been the wrong way of doing that since the code does in fact only take mere fractions of a second if I give it a clear defined range such as "A1:A100" in case of the first instance.

\$\endgroup\$
1
  • \$\begingroup\$ That's the difference in considering millions of cells versus a much smaller range. SO has many examples of how to find the last used row and/or column that you can incorporate to set your ranges more efficiently. \$\endgroup\$ Aug 23 '17 at 10:51

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.