This worked for me:

Option Explicit
Sub StartHere()

Dim rCell As Range
Dim rRng As Range

With Sheet2
Set rRng = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp))
End With

For Each rCell In rRng.Cells
CreateFolders rCell.Value & "-" & rCell.Offset(0, 5).Value, "C:\Test\"
Next rCell

End Sub
Sub CreateFolders(sSubFolder As String, ByVal sBaseFolder As String)

Dim eCtr As Long
Dim sTemp As String

On Error Resume Next
MkDir sBaseFolder
On Error GoTo 0

If Right(sBaseFolder, 1) < "\" Then
sBaseFolder = sBaseFolder & "\"
End If

sTemp = CleanFolderName(sSubFolder)

On Error Resume Next
MkDir sBaseFolder & sTemp
If Err.Number = 0 Then
'success
Else
'existing folder conflict
Err.Clear
eCtr = 0
Do
eCtr = eCtr + 1
MkDir sBaseFolder & sTemp & "(" & Format(eCtr, "00") & ")"
If Err.Number = 0 Then
'directory was created, so get out
Exit Do
End If
Err.Clear
Loop
End If
On Error GoTo 0

End Sub
Function CleanFolderName(ByVal sFolderName As String) As String

Dim i As Long
Dim sTemp As String

For i = 1 To Len(sFolderName)
Select Case Mid$(sFolderName, i, 1)
Case "/", "\", ":", "*", "?", "<", "", "|"
sTemp = sTemp & "_"
Case Else
sTemp = sTemp & Mid$(sFolderName, i, 1)
End Select
Next i

CleanFolderName = sTemp

End Function




Kerry wrote:

Does not compile. Get Error
Here is what I did with you new code.
Sub StartHere()

Dim rCell As Range
Dim rRng As Range

With Sheet2
Set rRng = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp))
End With

For Each rCell In rRng.Cells
CreateFolders rCell.Value & "-" & rCell.Offset(0, 5).Value, "C:\Test"

Next rCell

End Sub


Sub CreateFolders(sSubFolder As String, ByVal sBaseFolder As String)

Dim sTemp As String
Dim eCtr As Long 'near your other declarations in CreateFolders

If Len(Dir(sBaseFolder & sTemp)) = 0 Then
'doesn't exist.
'Use MkDir to create the folder
MkDir sBaseFolder & sTemp
Else
eCtr = 0
Do
eCtr = eCtr + 1
On Error Resume Next
MkDir sBaseFolder & sTemp & "(" & eCtr & ")"
If Err.Number = 0 Then
'directory was created, so get out
Exit Do
End If
'keep looking
Loop
End If


'Make sure the base folder is ready to have a sub folder
'tacked on to the end
If Right(sBaseFolder, 1) < "\" Then
sBaseFolder = sBaseFolder & "\"
End If

'Make sure base folder exists
If Len(Dir(sBaseFolder, vbDirectory)) 0 Then
'Replace illegal characters with an underscore
sTemp = CleanFolderName(sSubFolder)
'See if already exists: Thanks Dave W.
If Len(Dir(sBaseFolder & sTemp)) = 0 Then
'Use MkDir to create the folder
MkDir sBaseFolder & sTemp
End If
End If

End Sub

Function CleanFolderName(ByVal sFolderName As String) As String

Dim i As Long
Dim sTemp As String

For i = 1 To Len(sFolderName)
Select Case Mid$(sFolderName, i, 1)
Case "/", "\", ":", "*", "?", "<", "", "|"
sTemp = sTemp & "_"
Case Else
sTemp = sTemp & Mid$(sFolderName, i, 1)
End Select
Next i

CleanFolderName = sTemp

End Function

"Dave Peterson" wrote:

Untested, uncompiled...

Dim eCtr as long 'near your other declarations in CreateFolders
....
If Len(Dir(sBaseFolder & sTemp)) = 0 Then
'doesn't exist.
'Use MkDir to create the folder
MkDir sBaseFolder & sTemp
else
ectr = 0
do
ectr = ectr + 1
on error resume next
mkdir sbasefolder & stemp & "(" & ectr & ")"
if err.number = 0 then
'directory was created, so get out
exit do
end if
'keep looking
loop
end if
....

Kerry wrote:

Dave...Your code works although I found one issues with my data. Several
companies have multiple offices in the same location. So when the folder is
created and the code attempts to create the next company folder I get an
error because it is attempting to create a folder with the same name and
city. Is there away I can append a number to the folder based on some sort of
count to make the folder unique? E.g.

Column A- Column F(#)
TVC Capital LLC-Del Mar(1)
TVC Capital LLC-Del Mar(2)

I have several hundred companies with multiple branches in the same City.
Thanks for your assistance.
Kerry

"Dave Peterson" wrote:

Maybe...

Sub StartHere()

Dim rCell As Range
Dim rRng As Range

with Sheet1
set rRng = .range("A2",.cells(.rows.count,"A").end(xlup))
end with

For Each rCell In rRng.Cells
CreateFolders rCell.Value & "-" & rcell.offset(0,5).value, "C:\Test"
Next rCell

End Sub

rCell is in column A. .offset(0,5) is 5 columns to the right (column F).

Kerry wrote:

I have this code that loops through my worksheet and create new folders. I
need to use multiple columns to create my folder such as CompanyName in
Column A and CompanyCity in Column F. I would like to use a dash or
parentecies between the CompanyName and CompanyCity e.g.
CompanyName-CompanyCity.

Sub StartHere()

Dim rCell As Range, rRng As Range

Set rRng = Sheet1.Range("C2:C100")

For Each rCell In rRng.Cells
CreateFolders rCell.Value, "C:\Test"
Next rCell

End Sub

Sub CreateFolders(sSubFolder As String, ByVal sBaseFolder As String)

Dim sTemp As String

'Make sure the base folder is ready to have a sub folder
'tacked on to the end
If Right(sBaseFolder, 1) < "\" Then
sBaseFolder = sBaseFolder & "\"
End If

'Make sure base folder exists
If Len(Dir(sBaseFolder, vbDirectory)) 0 Then
'Replace illegal characters with an underscore
sTemp = CleanFolderName(sSubFolder)
'See if already exists: Thanks Dave W.
If Len(Dir(sBaseFolder & sTemp)) = 0 Then
'Use MkDir to create the folder
MkDir sBaseFolder & sTemp
End If
End If

End Sub

Function CleanFolderName(ByVal sFolderName As String) As String

Dim i As Long
Dim sTemp As String

For i = 1 To Len(sFolderName)
Select Case Mid$(sFolderName, i, 1)
Case "/", "\", ":", "*", "?", "<", "", "|"
sTemp = sTemp & "_"
Case Else
sTemp = sTemp & Mid$(sFolderName, i, 1)
End Select
Next i

CleanFolderName = sTemp

End Function

--

Dave Peterson


--

Dave Peterson


--

Dave Peterson