Как измерить вес фигур, форматирования ячеек и текста - для каждого листа

Private Sub RefreshSheetsList()
    Dim sh As Worksheet
    Dim used_cells As Long, Max_cells As Long, i As Long
    Dim ArrStr() As String
    Max_cells = 1
 
    For Each sh In ActiveWorkbook.Sheets
        If sh.Type = xlWorksheet Then
            ReDim Preserve ArrStr(0 To i)
            used_cells = WorksheetFunction.CountA(sh.Cells)
            ArrStr(i) = sh.Name & " кол ячеек: " & used_cells
            i = i + 1
            If used_cells > Max_cells Then Max_cells = used_cells
        End If
    Next sh
    i = 0
    For Each sh In ActiveWorkbook.Sheets
        If sh.Type = xlWorksheet Then
            Debug.Print ArrStr(i) & " " & WorksheetFunction.Rept("|", Int(20 * (WorksheetFunction.CountA(sh.Cells) / Max_cells)))
            i = i + 1
        End If
    Next sh
 
End Sub

Function FileSize(Path As String) As Long
    Dim sz As Long
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set File = fso.GetFile(Path)
    FileSize = File.Size
    Set File = Nothing
End Function

Public Const PathStr As String = "C:\UnZipped_test_data.xlsb.zip"
Sub ПримерИспользованияФункции_FilenamesCollection()
    ' Ищем на рабочем столе все файлы TXT, и выводим на лист список их имён.
    ' Просматриваются папки с глубиной вложения не более трёх.
 
    Dim coll As Collection, ПутьКПапке As String
    ' получаем путь к папке РАБОЧИЙ СТОЛ
    ПутьКПапке = PathStr
    ' считываем в колекцию coll нужные имена файлов
    Set coll = FilenamesCollection(ПутьКПапке, "*.*", 3)
 
    Application.ScreenUpdating = False    ' отключаем обновление экрана
    ' создаём новую книгу
    Dim sh As Worksheet: Set sh = Workbooks.Add.Worksheets(1)
    ' формируем заголовки таблицы
    With sh.Range("a1").Resize(, 4)
        .Value = Array("№", "Имя файла", "Полный путь", "Размер файла")
        .Font.Bold = True: .Interior.ColorIndex = 17
    End With
 
    ' выводим результаты на лист
    For i = 1 To coll.Count ' перебираем все элементы коллекции, содержащей пути к файлам
        sh.Range("a" & sh.Rows.Count).End(xlUp).Offset(1).Resize(, 4).Value = _
        Array(i, Dir(coll(i)), coll(i), FileSize(coll(i)))   ' выводим на лист очередную строку
        DoEvents    ' временно передаём управление ОС
    Next
    sh.Range("a:d").EntireColumn.AutoFit    ' автоподбор ширины столбцов
    [a2].Activate: ActiveWindow.FreezePanes = True ' закрепляем первую строку листа
End Sub

Private Function FileSize(Path As String) As Long
    Dim sz As Long
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set File = fso.GetFile(Path)
    FileSize = File.Size
    Set File = Nothing
End Function

Function FilenamesCollection(ByVal FolderPath As String, Optional ByVal Mask As String = "", _
                             Optional ByVal SearchDeep As Long = 999) As Collection
    ' © EducatedFool  excelvba.ru/code/FilenamesCollection
    ' Получает в качестве параметра путь к папке FolderPath,
    ' маску имени искомых файлов Mask (будут отобраны только файлы с такой маской/расширением)
    ' и глубину поиска SearchDeep в подпапках (если SearchDeep=1, то подпапки не просматриваются).
    ' Возвращает коллекцию, содержащую полные пути найденных файлов
    ' (применяется рекурсивный вызов процедуры GetAllFileNamesUsingFSO)
 
    Set FilenamesCollection = New Collection    ' создаём пустую коллекцию
    Set fso = CreateObject("Scripting.FileSystemObject")    ' создаём экземпляр FileSystemObject
    GetAllFileNamesUsingFSO FolderPath, Mask, fso, FilenamesCollection, SearchDeep ' поиск
    Set fso = Nothing: Application.StatusBar = False    ' очистка строки состояния Excel
End Function
 
Function GetAllFileNamesUsingFSO(ByVal FolderPath As String, ByVal Mask As String, ByRef fso, _
                                 ByRef FileNamesColl As Collection, ByVal SearchDeep As Long)
    ' перебирает все файлы и подпапки в папке FolderPath, используя объект FSO
    ' перебор папок осуществляется в том случае, если SearchDeep > 1
    ' добавляет пути найденных файлов в коллекцию FileNamesColl
    On Error Resume Next: Set curfold = fso.GetFolder(FolderPath)
    If Not curfold Is Nothing Then    ' если удалось получить доступ к папке
 
        ' раскомментируйте эту строку для вывода пути к просматриваемой
        ' в текущий момент папке в строку состояния Excel
        ' Application.StatusBar = "Поиск в папке: " & FolderPath
 
        For Each fil In curfold.Files    ' перебираем все файлы в папке FolderPath
            If fil.Name Like "*" & Mask Then FileNamesColl.Add fil.Path
        Next
        SearchDeep = SearchDeep - 1    ' уменьшаем глубину поиска в подпапках
        If SearchDeep Then    ' если надо искать глубже
            For Each sfol In curfold.SubFolders    ' перебираем все подпапки в папке FolderPath
                GetAllFileNamesUsingFSO sfol.Path, Mask, fso, FileNamesColl, SearchDeep
            Next
        End If
        Set fil = Nothing: Set curfold = Nothing    ' очищаем переменные
    End If
End Function