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.