批量删除文件夹中word文档空白行宏代码

csx

作为一个可怜的打工仔，每天都需要处理很多word文档，以前一个一个点开，然后用wps的智能排版，后来发现这也不是个事，废手啊这，于是便有了这个宏代码。python代码倒也试过，效率不太行，所以还是用这个吧。

[AppleScript] 纯文本查看 复制代码

Sub DeleteBlankLinesAndSave()
Dim i As Long
Dim j As Long
Dim k As Long
Dim n As Long
Dim rng As Range
Dim doc As Document
Dim folderPath As String
Dim file As String
 
'选择文件夹
With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "请选择需要处理的文件夹"
    .AllowMultiSelect = False
    If .Show <> -1 Then Exit Sub
    folderPath = .SelectedItems(1)
End With
 
Application.ScreenUpdating = False
 
'遍历文件夹中的所有文档
file = Dir(folderPath & "\*.doc")
Do While file <> ""
    Set doc = Documents.Open(folderPath & "\" & file)
    '删除空行
    For i = doc.Paragraphs.Count To 1 Step -1
        Set rng = doc.Paragraphs(i).Range
        If rng.text = vbCr Or rng.text = vbLf Or rng.text = vbCrLf Then
            rng.Delete
        End If
    Next i
    '保存文档
    doc.Save
    doc.Close
    '打开下一个文档
    file = Dir
Loop
 
Application.ScreenUpdating = True
End Sub