My problem is that since I have several companies with multiple locations, I
need to use an additional column to try and make the folders unique. In
addition I found that using CompanyName-City does not make it a unique folder
name so I need to include a count to the folder as well. Dave Pertersen
provided a snippet that works but when it attempts to create another folder
for the same company and city, if it is already created I get an error. I
think that sence I have multiple rows for the same company within the same
city I need to append a count such as:

CompanyName-City(1)
CompanyName-City(2)
CompanyName-City(3)

Here is Dave P. code:

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

"Barb Reinhardt" wrote:

And the problem is?

Barb Reinhardt




"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