常见文件格式批量整理VBS工具(支持docx, xlsx, txt)

pythonfun

一、软件名称： 文件格式批量整理工具
二、软件功能：
1. 去除TXT文件中的空行、行首行尾空格和制表位
2. 去除DOCX文件中的空段、段前和段尾空格和制表位
3. 去除XLSX文件中的空行、空列，单元格文字中前后多余的空格和制表位
三、使用方法：
1. 拖动一个或多个TXT、DOCX或XLSX文件到上面，就可以进行处理
2.返回的是处理的文件数量
四、使用截图

五、源码展示

[Visual Basic] 纯文本查看 复制代码

' --- 文本清理脚本 ---
Set fso = CreateObject("Scripting.FileSystemObject")
Set shell = CreateObject("WScript.Shell")

Dim txtCount, docxCount, xlsxCount
 txtCount = 0
 docxCount = 0
 xlsxCount = 0

If WScript.Arguments.Count = 0 Then
    MsgBox "请将要处理的 txt/docx/xlsx 文件拖到这个脚本上。", vbExclamation, "未提供文件"
    WScript.Quit
End If

For i = 0 To WScript.Arguments.Count - 1
    filePath = WScript.Arguments(i)
    If fso.FileExists(filePath) Then
        ext = LCase(fso.GetExtensionName(filePath))
        Select Case ext
            Case "txt"
                CleanTxt filePath
                txtCount = txtCount + 1
            Case "docx"
                CleanDocx filePath
                docxCount = docxCount + 1
            Case "xlsx"
                CleanXlsx filePath
                xlsxCount = xlsxCount + 1
        End Select
    End If
Next

MsgBox "文本清理完成：" & vbCrLf & _
       "TXT 文件：" & txtCount & vbCrLf & _
       "DOCX 文件：" & docxCount & vbCrLf & _
       "XLSX 文件：" & xlsxCount, vbInformation, "完成"

Sub CleanTxt(filePath)
    Dim inputStream, outputStream, cleanedText, line, lines, newFilePath

    ' === 1. 以 UTF-8 读取文本 ===
    Set inputStream = CreateObject("ADODB.Stream")
    inputStream.Type = 2 ' 文本模式
    inputStream.Charset = "utf-8"
    inputStream.Open
    inputStream.LoadFromFile filePath
    lines = Split(inputStream.ReadText, vbCrLf)
    inputStream.Close

    ' === 2. 清理文本内容：去空行、前后空格、制表符 ===
    cleanedText = ""
    For Each line In lines
        line = Trim(Replace(Replace(line, vbTab, ""), Chr(9), ""))
        If line <> "" Then cleanedText = cleanedText & line & vbCrLf
    Next

    ' === 3. 构造新文件名：原名_cleaned.txt ===
    newFilePath = Left(filePath, Len(filePath) - Len(fso.GetExtensionName(filePath)) - 1) & "_cleaned.txt"

    ' === 4. 以 UTF-8 写入新的文本文件 ===
    Set outputStream = CreateObject("ADODB.Stream")
    outputStream.Type = 2 ' 文本模式
    outputStream.Charset = "utf-8"
    outputStream.Open
    outputStream.WriteText cleanedText
    outputStream.SaveToFile newFilePath, 2 ' 2 = 覆盖模式（如果文件存在）
    outputStream.Close
End Sub


Sub CleanDocx(filePath)
    On Error Resume Next
    Dim wordApp, doc, para, paras, i, text, ext, newFilePath, saveFormat

    Set wordApp = CreateObject("Word.Application")
    wordApp.Visible = False

    Set doc = wordApp.Documents.Open(filePath, False, False)

    ' 倒序清理段落内容
    Set paras = doc.Paragraphs
    For i = paras.Count To 1 Step -1
        Set para = paras(i)

      text = para.Range.Text
      text = Replace(Replace(text, vbTab, ""), Chr(9), "") ' 去掉制表符
      text = Trim(text) ' 清除前后空白字符

    ' 去掉段尾空格但保留段落标记
     If Right(text, 1) = vbCr Or Right(text, 1) = vbLf Then
         text = RTrim(Left(text, Len(text) - 1)) & vbCr
     Else
         text = RTrim(text)
     End If

If Len(Replace(text, vbCr, "")) = 0 Then
    para.Range.Delete
Else
    para.Range.Text = text
End If



    Next

    ' 构造 _cleaned 文件名
    ext = LCase(fso.GetExtensionName(filePath))
    newFilePath = Left(filePath, Len(filePath) - Len(ext) - 1) & "_cleaned." & ext

    ' 设置保存格式
    If ext = "docx" Then
        saveFormat = 16 ' wdFormatDocumentDefault
    ElseIf ext = "doc" Then
        saveFormat = 0  ' wdFormatDocument
    Else
        saveFormat = 16
    End If

    doc.SaveAs2 newFilePath, saveFormat
    doc.Close False
    wordApp.Quit

    Set doc = Nothing
    Set wordApp = Nothing
    On Error GoTo 0
End Sub

Sub CleanXlsx(filePath)
    On Error Resume Next
    Dim xlApp, wb, ws, r, c, isEmpty, lastRow, lastCol, newFilePath, ext, baseName, saveFormat

    Set xlApp = CreateObject("Excel.Application")
    xlApp.Visible = False
    Set wb = xlApp.Workbooks.Open(filePath)

    For Each ws In wb.Worksheets
        lastRow = ws.UsedRange.Rows.Count
        lastCol = ws.UsedRange.Columns.Count

        ' 清理单元格内容（去除首尾空格、制表符、全角空格）
        For r = 1 To lastRow
            For c = 1 To lastCol
        If Not IsEmpty(ws.Cells(r, c).Value) Then
                Select Case VarType(ws.Cells(r, c).Value)
                Case vbString
                    val = ws.Cells(r, c).Value
                    val = Trim(Replace(val, vbTab, ""))
                    val = Replace(val, Chr(9), "")
                    val = Replace(val, ChrW(&H3000), "")
                    ws.Cells(r, c).Value = val
              Case vbDouble, vbInteger, vbLong
            ' 保留原值
             Case vbError
            ' 忽略错误单元格
            Case Else
            ' 其他类型不处理
            End Select
          End If

            Next
        Next

        ' 删除空行（从下往上）
        For r = lastRow To 1 Step -1
            isEmpty = True
            For c = 1 To lastCol
                If Trim(ws.Cells(r, c).Value) <> "" Then
                    isEmpty = False
                    Exit For
                End If
            Next
            If isEmpty Then ws.Rows(r).Delete
        Next

        ' 删除空列（从右往左）
        For c = lastCol To 1 Step -1
            isEmpty = True
            For r = 1 To ws.UsedRange.Rows.Count
                If Trim(ws.Cells(r, c).Value) <> "" Then
                    isEmpty = False
                    Exit For
                End If
            Next
            If isEmpty Then ws.Columns(c).Delete
        Next
    Next

    ' 构造新文件名
    ext = LCase(fso.GetExtensionName(filePath))
    baseName = Left(filePath, Len(filePath) - Len(ext) - 1)
    newFilePath = baseName & "_cleaned." & ext

    ' 设置保存格式（56 = .xls, 51 = .xlsx）
    If ext = "xls" Then
        saveFormat = 56 ' Excel 97-2003 Workbook
    Else
        saveFormat = 51 ' OpenXML Workbook (.xlsx)
    End If

    wb.SaveAs newFilePath, saveFormat
    wb.Close False
    xlApp.Quit

    Set wb = Nothing
    Set xlApp = Nothing
    On Error GoTo 0
End Sub

六、下载地址
文件格式整理清理工具 - pythonfun作品.zip (2.21 KB, 下载次数: 125)

2025-8-6 13:09 上传

点击文件名下载附件
下载积分: 吾爱币 -1 CB

ming_2794

加一个CSV文件以逗号“”分割的，去数据两头空格的就更完美了。是不是直接调用 CleanTxt就可以了呢？

fire1119e

很实用，多谢分享

brain00

感谢楼主的分享

wangxuan714

感谢楼主的分享

Lovestar46

感谢分享

v2850210

这个很好用。谢谢

zcc0206

工具无过，人需遵法

SONGXINGJING520

VBS现在还有这么多人用，也是难得了，

yoyouren

实用工具分享

Furutsukl

实用工具，感谢分享