12/24/2001
(edited 2/4/2006)

This is originally by Peter Beach from the microsoft.public.Excel.programming forum.

http://groups.google.com/groups?hl=en&rnum=3&selm=evjCXHDN$GA.275@cppssbbsa04

Just paste the code into the VB editor and run the code.
(It's best to have this window maximized. Sometimes the lines will wrap incorrectly.)

You’ll be asked the drive letter. The macro will then list all folders and their size.

You can change the Format Size section (near the end of the macro
to highlight any criteria.

It's set to show any folder greater than 10 Megs in red.
____________________________________________________________________

'***** Begin copy here *****

Option Explicit
Private Type FILETIME
        dwLowDateTime As Long
        dwHighDateTime As Long
End Type
Private Const MAX_PATH = 260
Private Const FILE_ATTRIBUTE_DIRECTORY = &H10

Private Type WIN32_FIND_DATA
        dwFileAttributes As Long
        ftCreationTime As FILETIME
        ftLastAccessTime As FILETIME
        ftLastWriteTime As FILETIME
        nFileSizeHigh As Long
        nFileSizeLow As Long
        dwReserved0 As Long
        dwReserved1 As Long
        cFileName As String * MAX_PATH
        cAlternate As String * 14
End Type

Private Declare Function FindClose Lib "kernel32" _
(ByVal hFindFile As Long) As Long

Private Declare Function FindFirstFile Lib "kernel32" _
Alias "FindFirstFileA" (ByVal lpFileName As String, _
lpFindFileData As WIN32_FIND_DATA) As Long

Private Declare Function FindNextFile Lib "kernel32" _
Alias "FindNextFileA" (ByVal hFindFile As Long, _
lpFindFileData As WIN32_FIND_DATA) As Long

Private m_lCurRow As Long
Private m_sSheet As Worksheet

Private Function GetFolderSize(ByVal Root) As _
Double
' --------------------------------------------------------------------
' FUNCTION:   to calculate bytes used in Root
'             and all subfolders of Root.
'             Root should be entered in the form
'             c:\Dir (or just c)
' --------------------------------------------------------------------

  Dim FData As WIN32_FIND_DATA
  Dim FHand As Long
  Dim sPath As String
  Dim StillOK As Long
  Dim ByteTotal As Double
  Dim nPos As Integer
  Dim DirName As String
  Dim OutRow As Long
  
  OutRow = m_lCurRow
  m_lCurRow = m_lCurRow + 1
  sPath = Root + "\*.*"
  
	Application.StatusBar = "Now entering " & Root & "data in row # " & m_lCurRow
	
  FHand = FindFirstFile(sPath, FData)

  If FHand <= 0 Then
      GetFolderSize = 0
    Exit Function
  End If
On Error Resume Next
  ByteTotal = 0
  Do
    If (FData.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) _
    = FILE_ATTRIBUTE_DIRECTORY Then
      nPos% = InStr(FData.cFileName, Chr$(0))
      DirName = Left$(FData.cFileName, nPos% - 1)
      If DirName <> "." And DirName <> ".." Then
        ByteTotal = ByteTotal + GetFolderSize _
        (Root + "\" + DirName)
      End If
    Else
      ByteTotal = ByteTotal + FData.nFileSizeLow
    End If

    StillOK = FindNextFile(FHand, FData)
  Loop Until StillOK = 0

  FHand = FindClose(FHand)
  GetFolderSize = ByteTotal
  
' Display results in the sheet
  
   
  m_sSheet.Cells(OutRow, 1).Value = Root
  m_sSheet.Cells(OutRow, 2).Value = ByteTotal

Application.StatusBar = ""
End Function


Sub GetFolderListing()

' --------------------------------------------------------------------
' DESCRIPTION:  Fills the sheet "Folder List" with directory name in
'               col A and size of directory in Col B
' --------------------------------------------------------------------
  Dim sDrive As String
  
  With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
    On Error Resume Next
    Sheets("Folder List").Delete
    On Error GoTo End_Error
    ActiveWorkbook.Worksheets.Add
    ActiveSheet.Name = "Folder List"
End_Error:
    End With
  
  sDrive = InputBox("Use C:\ or just C" & Chr$(13) & Chr$(13) & "See Status bar for progress", "Enter the letter of the drive to search")
  If Len(sDrive) = 0 Then Exit Sub
  
  sDrive = Left$(sDrive, 1) & ":"

  Set m_sSheet = Sheets("Folder List")

  m_sSheet.UsedRange.Clear
  m_lCurRow = 1
 
  GetFolderSize sDrive
  
  ' --------------------------------------------------------------------
  ' DESCRIPTION:  The following code enters column labels
  ' --------------------------------------------------------------------

    Rows("1:1").Select
    Selection.Insert Shift:=xlDown
    Range("A1") = "Folder"
    Range("B1") = "Size"
    Range("A1:B1").Select
    With Selection.Font
        .Name = "Arial"
        .Size = 12
        .Bold = True
    End With
    With Selection
        .HorizontalAlignment = xlCenter
    End With
    Columns("B:B").Select
' --------------------------------------------------------------------
' FORMAT SIZE:  The following code formats numbers
'               to display as kb with conditional formatting.
'               The comma after 0 divides the number by 1000
' --------------------------------------------------------------------
    Selection.NumberFormat = _
"[Red][>=10000000]#,##0,"" kb"";[Blue][<=10000000]#,##0,"" kb"";"
    Selection.Columns.AutoFit
    Range("A1").Select

End Sub

'***** End copy here *****