Excel VBA批量创建文件夹后自动生成写入B列内容的TXT文件

核心需求 #

• 按Excel当前选中区域的单元格值批量创建同名文件夹
• 每个生成的文件夹内自动创建name.txt文件
• name.txt内写入当前文件夹对应行B列的单元格内容
• 基于已有可正常创建文件夹的VBA代码补充逻辑，不改动原有可用功能

原有基础代码 #

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

补充后完整可用代码 #

Sub MakeFolders()
    Dim Rng As Range
    Dim maxRows As Integer, maxCols As Integer, r As Integer, c As Integer
    Dim folderPath As String, txtPath As String, fileNum As Integer
    Dim currentRow As Long
    
    ' 关闭屏幕更新提升运行速度
    Application.ScreenUpdating = False
    Set Rng = Selection
    maxRows = Rng.Rows.Count
    maxCols = Rng.Columns.Count
    
    ' 校验工作簿是否已保存
    If ActiveWorkbook.Path = "" Then
        MsgBox "请先保存当前Excel工作簿后再运行代码", vbExclamation
        Exit Sub
    End If
    
    For c = 1 To maxCols
        r = 1
        Do While r <= maxRows
            ' 跳过空单元格
            If Trim(Rng(r, c).Value) <> "" Then
                folderPath = ActiveWorkbook.Path & "\" & Rng(r, c)
                ' 文件夹不存在则创建
                If Len(Dir(folderPath, vbDirectory)) = 0 Then
                    MkDir folderPath
                End If
                ' 获取当前单元格对应的行号，取该行B列值
                currentRow = Rng.Cells(r, c).Row
                txtPath = folderPath & "\name.txt"
                ' 获取可用文件号
                fileNum = FreeFile()
                ' 打开文件写入内容，存在则覆盖
                Open txtPath For Output As #fileNum
                Print #fileNum, Cells(currentRow, "B").Value
                Close #fileNum
            End If
            r = r + 1
        Loop
    Next c
    
    ' 恢复屏幕更新
    Application.ScreenUpdating = True
    MsgBox "文件夹及对应txt文件生成完成", vbInformation
End Sub

关键说明 #

• 运行代码前必须先保存当前Excel文件，否则程序无法获取工作簿所在路径，会直接弹出提示退出
• 代码自动跳过选中区域内的空单元格，不会生成无效名称的文件夹
• 写入name.txt时会自动覆盖已有同名文件，内容始终和当前行B列值保持一致
• 新增屏幕更新开关，大批量生成时运行速度更快，不会出现界面卡顿
• 原有批量创建文件夹的逻辑完全保留，仅补充txt生成相关代码，同时修正了原代码中错误处理语句位置不当的问题

内容的提问来源于stack exchange，提问作者friendly