CreateFolder from Worksheet Columns

K

Kerry

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
 
D

Dave Peterson

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).
 
K

Kerry

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
 
K

Kerry

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
 
D

Dave Peterson

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
....
 
K

Kerry

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
 
D

Dave Peterson

You should see the counter in parentheses.

These were the folder names I got in my tests (of the newest version!!!):

C:\Test\asdf-qwer
C:\Test\asdf-qwer(01)
C:\Test\asdf-qwer(02)
C:\Test\asdf-qwer(03)
C:\Test\asdf-qwer(04)
C:\Test\asdf-qwer(05)
C:\Test\asdf-qwer(06)
C:\Test\asdf-qwer(07)
C:\Test\asdf-qwer(08)
C:\Test\asdf-qwer(09)
C:\Test\asdf-qwer(10)
C:\Test\asdf-qwer(11)
C:\Test\asdf-qwer(12)
C:\Test\asdf-qwer(13)
C:\Test\asdf-qwer(14)
C:\Test\asdf-qwer(15)
C:\Test\asdf-qwer(16)
C:\Test\asdf-qwer(17)
C:\Test\asdf-qwer(18)
C:\Test\asdf-qwer(19)
C:\Test\asdf-qwer(20)
I got it working. Is there away to appent eCtr to the Folder Name?
Click to expand...
 
D

Dave Peterson

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



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
Click to expand...
 
K

Kerry

Go it going. Dave, I greatly appreciate your help. I would like to eventually
add to this. I have another column of data I would like to integrate.
 
D

Dave Peterson

This portion might be the stuff you need to change:

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

If you wanted the value from column z of the same row (25 columns to the right
of column A), you could use:

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

But I don't really know what you want.
Go it going. Dave, I greatly appreciate your help. I would like to eventually
add to this. I have another column of data I would like to integrate.
Click to expand...
<<snipped>>
 
K

Kerry

Dave, thank you for your help. I have this all working and understand what we
have done. If you have time, I would like to take this one step further. Data
in column AC is either MainOffice or BranchOffice, how can I add these
subfolders to each folder we just created. All firms have a MainOffice and
many have a BranchOffice and many have several BranchOffices. Each Firm can
have 1 row or many rows. I would like to do this in a IF statement or Case
statement so long as this method is efficient. Your thoughts.

Also, my next item to address is creating a MS Word Document that is created
either with Bookmarks or MailMerge and place the individual file in its
rrespected folder then emailed to the Office Executive based on several email
addesses in my worksheet. Some help with this would be greatly appreciated.

Thanks Kerry
 
D

Dave Peterson

You can add more stuff to this portion:

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

Like

For Each rCell In rRng.Cells
CreateFolders rCell.Value _
& "-" & rCell.Offset(0, 5).Value _
& "-" & rcell.offset(0,25).value, "C:\Test\"
if isempty(rcell.offset(0,27).value) then
'skip it
else
'create a new folder
createfolders rcell.offset(0,27).value, _
"C:\test\" & rCell.Value _
& "-" & rCell.Offset(0, 5).Value _
& "-" & rcell.offset(0,25).value
end if
Next rCell

(untested, uncompiled. You'll want to pass the parent folder name to the
subroutine that creates the folder.)

As for the 2nd portion, you can look at Ron de Bruin's site. He has lots of
tips for emailing.

http://www.rondebruin.nl/tips.htm
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Adding a condition to VBA CountIF 7
the '$' in right$() 2
VBA - exporting serial letters to single documents 0
Unspecified Automation Error 11
multiple selection list box 0
Modify macro code to export multiple cell contents to multiple Text Files 3
Closing PDF file from Excel VBA (Adobe Reader, Adobe Acrobat, Browser) 0
Help needed! Extracting Heading 3 and Contents from a Word Doc to Excel 0

Top