Sub Excel批量生成TXT()
'==================== 声明变量 ====================
Dim savePath As String
Dim lastRow As Long, lastCol As Long
Dim i As Long, j As Long
Dim fileName As String, fileContent As String
Dim fso As Object, stream As Object
Dim fileExist As VbMsgBoxResult
Dim successCount As Long, skipCount As Long, failCount As Long
Dim fd As FileDialog '文件夹选择对话框
'==================== 配置区（按需修改）====================
' 1. 保存路径模式：True=弹出对话框手动选文件夹 False=默认Excel同目录
Const useSelectFolder = True
' 2. 数据起始行：默认第1行是表头，从第2行开始生成文件；无表头则改为1
Const startRow = 2
' 3. 内容拼接模式：
' 模式1 = 同行B列及以后内容用分隔符拼接为1行
' 模式2 = 每个单元格内容单独占1行
Const contentMode = 1
' 4. 同行内容分隔符（仅模式1生效）
Const separator = vbTab
' 5. 遇到同名文件时：True=弹出提示确认是否覆盖，False=直接覆盖不提示
Const confirmOverwrite = True
' 6. B列之后无内容时：True=生成空TXT文件，False=跳过该行不生成文件
Const createEmptyFile = False
'============================================================
'关闭屏幕刷新/事件，大幅提升运行速度，避免卡顿
Application.ScreenUpdating = False
Application.EnableEvents = False
'创建文件操作对象
Set fso = CreateObject("Scripting.FileSystemObject")
Set stream = CreateObject("ADODB.Stream")
'初始化统计计数
successCount = 0
skipCount = 0
failCount = 0
'-------------------------- 选择保存目录 --------------------------
If ThisWorkbook.Path = "" Then
MsgBox "请先将Excel文件保存到本地文件夹，再运行代码！", vbCritical, "错误"
GoTo 恢复设置
End If
If useSelectFolder Then
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
With fd
.Title = "请选择TXT文件存放文件夹"
.InitialFileName = ThisWorkbook.Path '默认打开当前表格所在文件夹
If .Show = -1 Then
savePath = .SelectedItems(1) & "\"
Else
'用户点击【取消】，直接退出过程，不生成任何文件
MsgBox "您未选择保存文件夹，本次操作已终止，不会生成TXT文件", vbInformation
Set fd = Nothing
GoTo 恢复设置
End If
End With
Set fd = Nothing
Else
savePath = ThisWorkbook.Path & "\"
End If
'确保保存路径存在，不存在则自动创建
If Not fso.FolderExists(savePath) Then
fso.CreateFolder savePath
MsgBox "已自动创建保存文件夹：" & savePath, vbInformation, "提示"
End If
'获取A列最后一行有数据的行号
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
If lastRow < startRow Then
MsgBox "未找到符合条件的A列姓名数据，请检查起始行配置！", vbExclamation, "提示"
GoTo 恢复设置
End If
'-------------------------- 主循环：批量生成文件 --------------------------
For i = startRow To lastRow
'1. 处理文件名（A列）
fileName = Trim(Cells(i, "A").Value)
If fileName = "" Then
skipCount = skipCount + 1
GoTo 下一行
End If
'过滤Windows文件名非法字符（半角+全角）
Dim badChars As Variant
badChars = Array("\", "/", ":", "*", "?", """", "<", ">", "|", "＼", "／", "：", "＊", "？", "＜", "＞", "｜")
For Each c In badChars
fileName = Replace(fileName, c, "")
Next c
fileName = savePath & fileName & ".txt"
'2. 处理文件内容（B列及以后）
fileContent = ""
lastCol = Cells(i, Columns.Count).End(xlToLeft).Column
If lastCol < 2 Then
If createEmptyFile Then
fileContent = ""
Else
skipCount = skipCount + 1
GoTo 下一行
End If
Else
Select Case contentMode
Case 1
For j = 2 To lastCol
fileContent = fileContent & Trim(Cells(i, j).Value) & separator
Next j
fileContent = Left(fileContent, Len(fileContent) - Len(separator))
Case 2
For j = 2 To lastCol
fileContent = fileContent & Trim(Cells(i, j).Value) & vbCrLf
Next j
fileContent = Left(fileContent, Len(fileContent) - 2)
End Select
End If
'3. 同名文件覆盖判断
If confirmOverwrite And fso.FileExists(fileName) Then
fileExist = MsgBox("文件已存在：" & fileName & vbCrLf & "是否覆盖？", vbYesNoCancel + vbQuestion, "确认覆盖")
Select Case fileExist
Case vbYes
Case vbNo
skipCount = skipCount + 1
GoTo 下一行
Case vbCancel
GoTo 循环结束
End Select
End If
'4. UTF-8写入文件
On Error Resume Next
stream.Charset = "UTF-8"
stream.Mode = 3
stream.Open
stream.WriteText fileContent
stream.SaveToFile fileName, 2
stream.Close
If Err.Number = 0 Then
successCount = successCount + 1
Else
failCount = failCount + 1
MsgBox "文件写入失败：" & fileName & vbCrLf & "错误：" & Err.Description, vbCritical
End If
On Error GoTo 0
下一行:
Next i
循环结束:
'结果弹窗
MsgBox "TXT文件生成任务完成！" & vbCrLf & vbCrLf & _
"✅ 成功生成：" & successCount & " 个" & vbCrLf & _
"⏭️ 已跳过：" & skipCount & " 个" & vbCrLf & _
"❌ 生成失败：" & failCount & " 个", vbInformation, "任务完成"
恢复设置:
Application.ScreenUpdating = True
Application.EnableEvents = True
Set stream = Nothing
Set fso = Nothing
End Sub
|
发表于 2026-7-15 10:51
|楼主
发表于 2026-7-15 13:55
分享到朋友圈
