Create folders from cell information, with the file "test.txt" inside each folder created (VBA)

Question

I have a spreadsheet with some information, I need this information to become folders and within each folder there is a file called "test.txt"

In a search, I found the following code:

Sub MakeFolders()
    Dim Rng As Range
    Dim maxRows, maxCols, r, c As Integer
    Set Rng = Selection
    maxRows = Rng.Rows.Count
    maxCols = Rng.Columns.Count
    For c = 1 To maxCols
        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 Sub

With this code it is possible to just create the folders without any file inside, someone can help me to complete the code?

Answer 1

Declare as Integer

First an observation:

Observing: Declare the Maxrows and Maxcols like Long (Dim Maxrows As Long), because many old tutorials use Integer, which has 2 bytes and the range from -32 768 to 32 767. So if the Excel version is longer than 2007, the program will stop after line 32767. Long has 4 bytes and a range of -2 147 483 648 to 2 147 486 647. Where the Excel has a limit of 1 048 576 lines.

And declaring in the form:

Dim maxRows, maxCols, r, c As Integer

Only c is like Integer, all other variables are Variant.

The right thing would be:

Dim maxRows As Long, maxCols As Long, r As Long, c As Long

Otherwise the code is correct and would work. It works with Selection, then first the desired range must be selected.

Solution

I like to check if the path exists before trying to create the folder, to avoid errors (What already occurs in code with If Len(Dir(ActiveWorkbook.Path & "\" & Rng(r, c), vbDirectory)) = 0 Then).

With ActiveWorkbook.Path & "\" & Rng(r, c) the path of the Excel file directory is being used as reference to create the folders.

It follows the way I use adapted to your code, which does not necessarily need to be in the same folder as the Excel file, but the complete path must be inserted:

Sub MakeFolders()
    Dim Rng As Range
    Dim maxRows As Long, maxCols As Long, r As Long, c As Long
    Set Rng = Selection
    maxRows = Rng.Rows.Count
    maxCols = Rng.Columns.Count
    For c = 1 To maxCols
        r = 1
        Do While r <= maxRows
            CriarCaminho (Rng(r, c))
            r = r + 1
        Loop
    Next c
End Sub

Public Function CriarCaminho(ByVal path As String) As Boolean

    CriarCaminho = True
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")

    If fso.FolderExists(path) Then
        Exit Function
    Else
        On Error GoTo DeadInTheWater
        fso.CreateFolder path
        Exit Function
    End If

DeadInTheWater:
    MsgBox "A folder could not be created for the following path: " & path & ". Check the path name and try again."
    CriarCaminho = False
    Exit Function

End Function

Reference

To use the Scripting.FileSystemObject, the reference shall be added in the VBE.

In Tools -> References...

Add the 'Microsoft Scripting Runtime''

Answer 2

I added the sub-generationArqTXT below its code, basically, this sub creates a new spreadsheet and saves it in text format. Inside your code, I called the sub, sending the name of the concatenated folder with the file name (and a '\').

Sub MakeFolders()
    Dim Rng As Range
    Dim maxRows, maxCols, r, c As Integer
    Set Rng = Selection
    maxRows = Rng.Rows.Count
    maxCols = Rng.Columns.Count
    For c = 1 To maxCols
        r = 1
        Do While r <= maxRows
            If Len(Dir(ActiveWorkbook.Path & "\" & Rng(r, c), vbDirectory)) = 0 Then
                MkDir (ActiveWorkbook.Path & "\" & Rng(r, c))
                filename = (ActiveWorkbook.Path & "\" & Rng(r, c)) & "\teste.txt" 'sua pasta + teste.txt
                geraArqTXT filename 'passando pra função
                On Error Resume Next
            End If
            r = r + 1
        Loop
    Next c
End Sub

Public Sub geraArqTXT(fn As String)


    Dim work As Workbook
    Dim sht As Worksheet
    Set work = Workbooks.Add 'cria uma nova planilha
    Set sht = work.Worksheets.Add 'cria uma nova pasta


sht.SaveAs fn, xlTextPrinter 'salva sua pasta de trabalho como texto no destino recebido (fn)

work.Close SaveChanges:=True
    Set work = Nothing



End Sub