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.
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") &lt;&gt; "No Summary Available" Then _

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

        For Each c In copyRng.SpecialCells(xlCellTypeVisible)

            If Len(c) &lt;&gt; 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") &lt;&gt; "No Summary Available" Then _

        Set copyRng = xSheet.Cells

        For Each c In copyRng.SpecialCells(xlCellTypeVisible)

            If Len(c) &lt;&gt; 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.
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.