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 WorksheetDim DestSh As WorksheetDim Last As LongDim copyRng As RangeDim destRng As RangeDim cRange As RangeDim c As RangeDim uniqueVal() As VariantDim x As LongWith Application    .ScreenUpdating = False    .EnableEvents = FalseEnd With'Delete the summary worksheet if it exists.Application.DisplayAlerts = FalseOn Error Resume NextActiveWorkbook.Worksheets(Summary).DeleteOn Error GoTo 0Application.DisplayAlerts = True' Add a worksheet with the name SummarySet DestSh = ActiveWorkbook.Worksheets.AddDestSh.Name = SummaryDestSh.Range(A1).Value = AccountDestSh.Range(B1).Value = ExchangeDestSh.Range(C1).Value = QuarterDestSh.Range(D1).Value = YearSet destRng = DestSh.Range(E1)'Define inital array valuesuniqueVal = 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 IfNext 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 IfNext xSheetExitTheSub:Application.Goto DestSh.Cells(1)With Application    .ScreenUpdating = True    .EnableEvents = TrueEnd WithEnd SubSorry for the massive block of code.
Iterating worksheets and cells, copying data to summary sheet
excel;vba
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.CellsAll 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.