|
|
请备份原文件后应用：
Sub 循环遍历文件夹_产品名称另存为()
On Error Resume Next
Dim fd As FileDialog, i As Long, doc As Document, p As String
MsgBox "请注意！所有文件夹及子文件夹中的文档另存为后都保存在 C 盘【产品名称另存为】文件夹中！下面请选定欲处理文档所在的文件夹（要双击）！", vbOKOnly + vbExclamation, "Save As"
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
If fd.Show = -1 Then p = fd.SelectedItems(1) Else Exit Sub
Set fd = Nothing
If MsgBox("Are you sure to process the folder " & p & " ?" & vbCr & "是否处理文件夹 " & p & " ？", vbYesNo + vbExclamation, "循环遍历文件夹") = vbNo Then Exit Sub
With Application.FileSearch
.LookIn = p
.SearchSubFolders = True
.FileName = "*.doc"
If .Execute > 0 Then
For i = 1 To .FoundFiles.Count
Set doc = Documents.Open(FileName:=.FoundFiles(i))
Dim j As String, myRange As Range
Set myRange = ActiveDocument.Tables(1).Cell(2, 1).Range
myRange.Select
Selection.Find.Execute FindText:="^l", ReplaceWith:="", Replace:=wdReplaceAll
myRange.Select
Selection.Find.Execute FindText:="^p", ReplaceWith:="", Replace:=wdReplaceAll
myRange.Select
Selection.Find.Execute FindText:="^w", ReplaceWith:="", Replace:=wdReplaceAll
Selection.Find.Execute FindText:=" ", ReplaceWith:="", Replace:=wdReplaceAll
myRange.Select
Selection.MoveEnd unit:=wdCharacter, Count:=-1
j = Selection.Text
If Asc(j) = 13 Then MsgBox "【产品名称】下面单元格为空，无法保存！", vbOKOnly + vbCritical, "Save As": End
If Len(Dir("C:\产品名称另存为", vbDirectory)) = 0 Then MkDir "C:\产品名称另存为"
ActiveDocument.SaveAs FileName:="C:\产品名称另存为\" & j & ".doc"
ActiveDocument.Close
Next i
MsgBox "Complete! There were " & .FoundFiles.Count & " file(s) processed." & vbCr & "处理完毕！共处理 " & .FoundFiles.Count & " 个文件！", vbOKOnly + vbExclamation, "循环遍历文件夹"
Else
MsgBox "There were no files found." & vbCr & "未发现文件！", vbOKOnly + vbCritical, "循环遍历文件夹"
End If
End With
End Sub |
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2014-1-5 17:50
楼主
