Excel macro to check the size of each worksheet of workbook?

Excel is highly recommended reporting tool which used in diverse industry for reporting purpose. Though, it is very useful by it's various reporting functionality. It has some limitation which will be taken into consideration while generation reporting tools. Workbook size is one of the limitation which slow down performance of reports which contains huge data. There could be various causes which impact on file size. In fact, to overcome this file size limitation, we identify the sheet which is result in increase in file size and optimize it to decrease overall size on disk.

Finding size of each sheet is not a simple task. But, it can be possible with excel VBA code. Here is the code which will give you size of each sheet in your report.

Sub Get_Sheets_Size()
' Author: Dreams24
' Written for VBA Tricks and tips blog
' https://vbatricksntips.com

Dim ShtArray(), Bytes As Double, i As Long, FileNameTmp As String
Dim Wb As Workbook
Dim str As String

Set Wb = ActiveWorkbook
ReDim ShtArray(0 To Wb.Sheets.Count, 1 To 2)

' Turn off screen updating
   Application.ScreenUpdating = False

On Error GoTo Err-Handler

' Put names into ShtArray(,1) and sizes into ShtArray(,2)
With CreateObject("Scripting.FileSystemObject")
' Build the temporary file name
FileNameTmp = .GetSpecialFolder(2) & "\" & Wb.Name & ".TMP"
' Save workbook
Wb.SaveCopyAs FileNameTmp
' Put workbook's name and size into ShtArray(0,)
ShtArray(0, 1) = Wb.Name
ShtArray(0, 2) = .GetFile(FileNameTmp).Size
' Put each sheet name and its size into ShtArray(i,)
For i = 1 To Wb.Sheets.Count
Wb.Sheets(i).Copy
ActiveWorkbook.SaveCopyAs FileNameTmp
ShtArray(i, 1) = Wb.Sheets(i).Name
ShtArray(i, 2) = .GetFile(FileNameTmp).Size
Bytes = Bytes + ShtArray(i, 2)
ActiveWorkbook.Close False
Next
' Delete Temporary file created to calculate each sheets size
Kill FileNameTmp
End With

str = ""

' for loop to store each sheet name and its corrected size
For i = 1 To UBound(ShtArray)
Debug.Print ShtArray(i, 1), Format(ShtArray(0, 2) * ShtArray(i, 2) / Bytes, "# ### ### ##0") & " Bytes"
str = str & vbNewLine & ShtArray(i, 1) & Format(ShtArray(0, 2) * ShtArray(i, 2) / Bytes, "# ### ### ##0") & " Bytes"

Next

MsgBox ShtArray(0, 1) & " " & Format(ShtArray(0, 2), "# ### ### ##0") & " Bytes" & vbNewLine & str, vbInformation

Err-Handler:

' Enable screen updating and show error reason if happened
Application.ScreenUpdating = True

' Error Handling code
If Err Then MsgBox Err.Description, vbCritical, "Error"

End Sub