Create folders and subfolder and sub text files from excel sheet-CodePudding

hi i'm trying to create a list of folders from an excel sheet and in each folder, it should be a txt file named let's say name.txt and in each of these files it should write wats in column b pic 1

I used this code to create the folders but I need help about creating the txt files

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

I need help generating the text file in each folder

CodePudding user response：

Create Text Files From Worksheet Data

Sub MakeFolders()
    
    Const fRow As Long = 2
    Const SubFolderColumn As String = "A"
    Const TextColumn As String = "B"
    Const TextFileNameCellAddress As String = "B1"
    
    Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
    
    Dim wbPath As String: wbPath = ws.Parent.Path & "\"
    
    Dim TextFileName As String
    TextFileName = CStr(ws.Range(TextFileNameCellAddress).Value)
    
    Dim lRow As Long
    lRow = ws.Cells(ws.Rows.Count, SubFolderColumn).End(xlUp).Row
    Dim srg As Range: Set srg = ws.Range(ws.Cells(fRow, SubFolderColumn), _
        ws.Cells(lRow, SubFolderColumn))
    
    Dim sCell As Range
    Dim TextFile As Long
    Dim FolderPath As String
    Dim SubFolderName As String
    Dim FilePath As String
    Dim FileText As String
    
    For Each sCell In srg.Cells
        SubFolderName = CStr(sCell.Value)
        If Len(SubFolderName) > 0 Then
            FolderPath = wbPath & SubFolderName & "\"
            If Len(Dir(FolderPath, vbDirectory)) = 0 Then
                MkDir FolderPath
            End If
            FilePath = FolderPath & TextFileName
            FileText = CStr(sCell.EntireRow.Columns(TextColumn).Value)
            ' Or (the same):
            'FileText = CStr(ws.Cells(sCell.Row, TextColumn).Value)
            TextFile = FreeFile
            Open FilePath For Output As #TextFile
                Print #TextFile, FileText
            Close TextFile
        End If
    Next sCell
    
    MsgBox "Files created.", vbInformation
    
End Sub

CodePudding user response：

try to use FSO.CreateTextFile:

Sub Macro1()
'
' Macro1 Macro
'

'
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    Dim strPath As String
    strPath = "d:\name.txt"
    Dim oFile As Object
    Set oFile = fso.CreateTextFile(strPath)
    oFile.WriteLine "test"
    oFile.Close
    Set fso = Nothing
    Set oFile = Nothing
End Sub