Sub SizeOfWorksheets()
Dim wb As Workbook, wbResults As Workbook, wbTmp As Workbook
Dim sh As Worksheet, shResults As Worksheet
Dim lSheets As Long, rw As Long
Dim fs As Object
Dim filename As String
filename = Application.DefaultFilePath & "\Crapname.xls"
lSheets = Application.SheetsInNewWorkbook
Application.SheetsInNewWorkbook = 1
Application.DisplayAlerts = False
Set wb = ActiveWorkbook
Set wbResults = Workbooks.Add
Set shResults = wbResults.ActiveSheet
shResults.Cells(1, 1).Value = "Worksheet"
shResults.Cells(1, 2).Value = "Number of Bytes"
shResults.Cells(1, 3).Value = "Less Overhead"
rw = 2
For Each sh In wb.Worksheets
Set wbTmp = Workbooks.Add
sh.Copy after:=wbTmp.Worksheets(1)
wbTmp.Worksheets(1).Delete
wbTmp.SaveAs filename
shResults.Cells(rw, 1).Value = sh.Name
shResults.Cells(rw, 2).Value = FileLen(filename)
shResults.Cells(rw, 3).Value = shResults.Cells(rw, 2).Value - 13000
wbTmp.Close
rw = rw + 1
Next
shResults.Columns("A:C").AutoFit
Set fs = CreateObject("Scripting.FileSystemObject")
fs.DeleteFile filename
Application.SheetsInNewWorkbook = lSheets
Application.DisplayAlerts = True
End Sub