Sub DetermineFolderSizes()
Dim wbNew As Workbook
Dim r As Range
Dim startFolder As String
startFolder = "c:\"
Set wbNew = Workbooks.Add
wbNew.Activate
Set r = ActiveSheet.Cells(1, 1)
FolderSizes startFolder, r
End Sub
Function FolderSizes(folder As String, r As Range) As Long
Dim fs, f, f1, fc, sfc, sf, s
Dim mySize As Range
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(folder)
Set sfc = f.Subfolders
Set fc = f.Files
r.Value = folder
Set r = r.Offset(0, 1)
Set mySize = r
mySize.Value = 0
For Each sf In sfc
Set r = r.Offset(1, 0)
mySize.Value = mySize.Value + FolderSizes(sf.Path, r)
Next
For Each f1 In fc
mySize.Value = mySize.Value + FileLen(f1)
Next
Set r = r.Offset(0, -1)
FolderSizes = mySize.Value
End Function