This is the code I am using. Sub MakeFolders()
Dim Rng As Range
Dim LastRow As Long
Dim LastColumn As Long
Dim maxRows As Integer
Dim r As Integer
Dim c As Integer
Set sht = Worksheets("Sheet1")
Set StartCell = Range("M:M")
LastRow = sht.Cells(sht.Rows.Count, StartCell.Column).End(x1UIP).Row
LastColumn = 1
sht.Range(StartCell, sht, Cells(LastRow, LastColumn)).Select
Set Rng = Selection
maxRows = Rng.Rows.Count
For c = 1 To 1
r = 1
Do While r <= maxRows
If Len(Dir(ActiveWorkbook.Path & "\" & Rng(r, c), vbDirectory)) = 0 Then
MkDir (ActiveWorkbook.Path & "\" & Rng(r, c))
On Error Resume Next
End If
r = r + 1
Loop
Next c
End Su