# Iterating worksheets and cells, copying data to summary sheet

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.
On Error Resume Next
ActiveWorkbook.Worksheets("Summary").Delete
On Error GoTo 0

' Add a worksheet with the name "Summary"
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
' 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.

• stackoverflow.com/q/7103552/1531971 might be related.
– jdv
Aug 22 '17 at 14:56
• @jdv That has to do with benchmarking code, not increasing the performance of the code. Aug 22 '17 at 17:45
• 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 Aug 23 '17 at 0:12
• @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. Aug 23 '17 at 7:21
• 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. Aug 23 '17 at 10:49

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