Excel freezes when running macro on large files (hiding bold rows and transposing to new sheet) - hide

Question

I am wondering if anyone can help me with this macro. It works on smaller files, but on bigger files, Excel goes to not responding mode. I am not even sure if it is actually running in the background or really not responding. Maybe it can be streamlined more?
Basically I have a workbook with many many sheets (over 1000 sheets) where only column A is populated, and I wanted to hide the non-bold rows, and transpose the visible bold rows of each sheet into a new row one after another, into a new sheet call 'Table of Contents'.
Also, I am not sure if 'UsedRange' to hide bold rows would be okay to use here, there's less than 50 rows, but when the macro runs, it looks like it's trying to hide way pass that, maybe because there are some blank rows.
I want Application.ScreenUpdating to be true because I would like to see that it is doing the job.
I am fairly new to vba so I would really appreciate if someone can help me with this!
Thank you so much!!!
Below is the code:
Sub AW_CopyTransposeBoldText()
Dim sFname As Variant Dim i As Long
'OPENS DIALOG WINDOW sFname = Application.GetOpenFilename(FileFilter:="Microsoft Excel Workbooks (.xls;.xlsx;.xlsm),.xls;.xlsx;.xlsm", Title:="SELECT YOUR FILES =)", MultiSelect:=True)
If IsArray(sFname) Then
For i = LBound(sFname) To UBound(sFname)
Workbooks.Open Filename:=sFname(i)
Next i
Else: MsgBox "No files selected!", vbExclamation, "Sorry!"
End If
Dim c As Range Dim ws As Worksheet, wb As Workbook
For Each wb In Workbooks 'LOOPS THROUGH ALL OPEN WORKBOOKS wb.Activate
ActiveWorkbook.Sheets.Add(Before:=Worksheets(1)).Name = "Table of Contents" 'ADD WORKSHEET AND HEADERS
Cells(1, 1) = "Page Number"
Cells(1, 2) = "Address 1"
Cells(1, 3) = "Address 2"
Cells(1, 4) = "Address 3"
For i = 2 To Sheets.Count 'LOOPS THROUGH ALL WORKSHEETS 1 TO LAST SHEET
Worksheets(i).Activate
Application.ScreenUpdating = True
For Each ws In Worksheets 'LOOPS THROUGH ALL WORKSHEETS AGAIN?
ActiveSheet.DisplayPageBreaks = False
For r = 1 To ActiveSheet.UsedRange.Rows.Count
Cells(r, 1).EntireRow.Hidden = Cells(r, 1).Font.Bold = False
Next r
Next ws
Range("A1:IV" & Range("A65536").End(xlUp).Row).SpecialCells(xlCellTypeVisible).Copy
'Change number to the destination sheet number you want to import to (starts with 1)
ActiveWorkbook.Worksheets("Table of Contents").Activate
'Do not change the following column. It's not the same column as above
Range("B" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=True, Transpose:=True
Application.CutCopyMode = False
Next i 'NEXT WORKSHEET LOOP
Next wb 'NEXT WORKBOOK LOOP
MsgBox "DONE!!"
End Sub

Answer 1

You could try the following method to increase the performance of your VBA.
Solution:-
Task 1: Increase your virtual memory
Open the control panel > on the right hand top corner >Select view by "small icons"
Select System> Advanced System Settings> Under Advanced> Performance> click Settings
Click Advanced > Virtual memory> Change
Uncheck the "Automatically manage paging file size for all drives"
Click on C drive> Click custom size > Set Initial size as your RAM size Ex: If you have 6 Gig of RAM then it will be 1024*6=6144
On the Maximum Size> Double your RAM Size. In this case it will be 12288 . See below screen shot
7.Click "Set" Button > Click > OK. Then Reboot your machine to see the changes
Task 2: Changing your Excel Settings
Click File > Options> Advanced> Under Editing options> Uncheck the "Allow editing directly in cells" and "Automatically Flash Fill"
Click File > Options> Advanced> Under Display options > Click Disable Hardware graphics acceleration
This will increase almost 67 % of improvements in Excel
Tip: Always use Paste special values when you paste something on Excel