Мне интересно, может ли кто-нибудь помочь мне с этим макросом. Он работает с небольшими файлами, но для больших файлов Excel переходит в режим отсутствия ответа. Я даже не уверен, работает ли он в фоновом режиме или действительно не отвечает. Может быть, это можно упростить еще?
По сути, у меня есть рабочая книга со множеством листов (более 1000 листов), в которой заполняется только столбец А, и я хотел скрыть не выделенные жирным шрифтом строки и переставить видимые жирные строки каждого листа в новый ряд один за другим. другой, в новый лист, назовите «Оглавление».
Кроме того, я не уверен, что 'UsedRange', чтобы скрыть жирные строки, было бы хорошо использовать здесь, там меньше 50 строк, но когда макрос запускается, похоже, что он пытается скрыть этот путь, возможно, потому что там некоторые пустые строки.
Я хочу, чтобы Application.ScreenUpdating был истинным, потому что я хотел бы видеть, что он выполняет свою работу.
Я довольно новичок в vba, поэтому я был бы очень признателен, если бы кто-нибудь смог мне помочь с этим!
Большое вам спасибо !!!
Ниже приведен код:
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