vba -create folders

Question

Hi

I have code below to create folders and save them into my H drive folder ("customers for Jan 2017") based on a list of emails addresses; Eg: worksheets("Customer Outgoing Email List").range("A:A") contains a list of email address. I want the vba code below to create folders for those emails address. I found code below to do this, but it doesn't work everytime . Is that because I need to add the  "loop".  In addition can I  also use vba to trim the letter. Eg *********@gmail.com Is there any way that I can add some code into below code to remove @gmail.com ? currently  I am using excel formula =left("A1",Len("A1") -11) to do this for me. Any help is truly appreciated!

I started learning VBA since late last year, and received a lot help on this website, I learned so much since. So I truly appreciated for all your help on my VBA self learning journey.

Sub MakeFolders()

    Dim xdir As String

    Dim fso

    Dim lstrow As Long

    Dim i As Long

    Set fso = CreateObject("Scripting.FileSystemObject")

    lstrow = Worksheets("Customer Outgoing Email List").Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row

    Application.ScreenUpdating = False

    For i = 1 To lstrow

        'change the path on the next line where you want to create the folders

        xdir = "H:\My Documents\customers for Jan 2017" & Range("A" & i).Value

         If Not fso.FolderExists(xdir) Then

            fso.CreateFolder (xdir)

        End If

    Next

    Application.ScreenUpdating = True

End Sub

***Personal information deleted by the moderator. Please see the Microsoft Community Frequently Asked Questions for more information on how you can protect your privacy.***

Answer 1

Looking at the code it seems probable that the process cannot create the path and there are some other issues also. Try the following instead, which does work:

Option Explicit

Sub MakeFolders()

Dim strDir As String

Dim lstRow As Long

Dim i As Long

Dim xlBook As Workbook

Dim xlSheet As Worksheet

Const strName As String = "Customer Outgoing Email List"

    Set xlBook = ActiveWorkbook

    Set xlSheet = xlBook.Worksheets(strName)

    lstRow = xlSheet.Cells(xlSheet.Rows.Count, "A").End(xlUp).Row

    Application.ScreenUpdating = False

    For i = 1 To lstRow 'I guess no header row?

        'change the path on the next line where you want to create the folders

        strDir = "H:\My Documents\customers for Jan 2017" & _

                 Left(Range("A" & i).Value, InStrRev(Range("A" & i).Value, "@") - 1)

        If CreateFolders(strDir) = False Then GoTo lbl_exit

        DoEvents

    Next

    Application.ScreenUpdating = True

lbl_exit:

    Set xlBook = Nothing

    Set xlSheet = Nothing

    Exit Sub

End Sub

Private Function CreateFolders(strPath As String) As Boolean

'A Graham Mayor/Greg Maxey AddIn Utility Macro

'This will create the full path (if missing) but will create an error message and stop processing

'if the drive letter does not exist, or the path contains illegal characters.

Dim oFSO As Object

Dim lngPathSep As Long

Dim lngPS As Long

    On Error GoTo err_Handler

    If Right(strPath, 1) <> "" Then strPath = strPath & ""

    lngPathSep = InStr(3, strPath, "")

    If lngPathSep = 0 Then GoTo lbl_exit

    Set oFSO = CreateObject("Scripting.FileSystemObject")

    Do

        lngPS = lngPathSep

        lngPathSep = InStr(lngPS + 1, strPath, "")

        If lngPathSep = 0 Then Exit Do

        If Len(Dir(Left(strPath, lngPathSep), vbDirectory)) = 0 Then Exit Do

    Loop

    Do Until lngPathSep = 0

        If Not oFSO.FolderExists(Left(strPath, lngPathSep)) Then

            oFSO.CreateFolder Left(strPath, lngPathSep)

        End If

        lngPS = lngPathSep

        lngPathSep = InStr(lngPS + 1, strPath, "")

    Loop

    CreateFolders = True

lbl_exit:

    Set oFSO = Nothing

    Exit Function

err_Handler:

    MsgBox "Unable to create " & vbCr & strPath & vbCr & vbCr & _

           "Error Number: " & Err.Number & vbCr & Err.Description

    Err.Clear

    GoTo lbl_exit

End Function

Answer 2

How about

xDir = "H:\My Documents\customers for Jan 2017" & _

           Left(Range("A" & i).Value, InStrRev(Range("A" & i).Value, "@") - 1)

Answer 3

I Can't thank your more enough for your kind help again! I truly appreciated!!

Answer 4

Can I ask for more help from excel gurus again?

• the code worked as long as if I step through the codes by pressing F8 key. But it gives me the message Run-time'5' error message: Invalid procedure call or argument if I press the command button. The command button is the form control button. I checked that I assigned the right Macro to it. But something I am doing correctly, and I don't know what it is? the codes are modified to below:

Sub MakeFolders()

    Dim xdir As String

    Dim fso

    Dim lstrow As Long

    Dim i As Long

    Set fso = CreateObject("Scripting.FileSystemObject")

    lstrow = Worksheets("Customer Outgoing Email List").Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row

    Application.ScreenUpdating = False

    For i = 1 To lstrow

        'change the path on the next line where you want to create the folders

       xDir = "H:\My Documents\customers for Jan 2017" & _

           Left(Range("A" & i).Value, InStrRev(Range("A" & i).Value, "@") - 1)

         If Not fso.FolderExists(xdir) Then

            fso.CreateFolder (xdir)

        End If

    Next

    Application.ScreenUpdating = True

End Sub

Answer 5

Thanks so much Graham! this is the 2nd time you have been help me. I truly appreciated your time.  Your code did the wonder. Thank you so much! and also thanks to all the people who helped me!