按照WORD内容批量修改文件名

尕司令 · 发表于 2022-3-8 16:02

由固定模板生成的申请表需要以申请人姓名+身份证号命名如果命名后有重复添加序号有的学生存在多次导出所以会有重复

类似案例帖子
https://club.excelhome.net/thread-1335079-1-7.html

参考代码
参考代码.jpg

Sub AutoOpen()
UserForm1.ComboBox1.List = Array("doc文件", "docx文件", "docm文件")
End Sub
Sub 重命名()
Dim thispath$, myfile$, mydoc As Document, sr$
With Application.FileDialog(msoFileDialogFolderPicker)
   .InitialFileName = ActiveDocument.Path
   .Title = "选取待压缩文件位置"
   .ButtonName = "选定路径"
   If .Show = -1 Then SelPth = .SelectedItems(1)
End With
If Len(SelPth) > 0 Then thispath = SelPth & "\": pth = Left$(SelPth, InStrRev(SelPth, "\") - 1) & "\"
      On Error Resume Next
      MkDir pth & "命名后文档"
      On Error GoTo 0
myfile = Dir(thispath & "*.doc")
Select Case UserForm1.ComboBox1.Text
   Case "doc文件"
      hzh = ".doc"
      typ = wdFormatDocument
   Case "docx文件"
      hzh = ".docx"
      typ = wdFormatXMLDocument
   Case Else
      hzh = ".docm"
      typ = wdFormatXMLDocumentMacroEnabled
End Select
Do While myfile <> ""
If myfile <> ActiveDocument.Name Then
      Set mydoc = Documents.Open(thispath & myfile)
      sr = mydoc.Tables(1).Cell(2, 3).Range.Text
      sr = Replace(Replace(sr, " ", ""), Chr(13) & Chr(7), "")
      targetstr = pth & "命名后文档\" & sr & hzh
      mydoc.SaveAs2 targetstr, FileFormat:=typ
      If UserForm1.CheckBox1.Value = True Then
         mydoc.ExportAsFixedFormat OutputFileName:=pth & "命名后文档\" & sr & ".pdf", ExportFormat:=wdExportFormatPDF '转为pdf格式文件
      End If
      mydoc.Close 0
End If
myfile = Dir
Loop
End Sub

尕司令 · 发表于 2022-3-8 16:03

提取姓名和学生身份证号作为新文件名

蜀中草莽 · 发表于 2022-3-9 09:10

建议在源数据表加一列辅助列姓名+身份证号作为命名依据，然后合并到不同的新文档，以辅助列命名！

蜀中草莽 · 发表于 2022-3-9 11:31

尕司令发表于 2022-3-8 16:03
提取姓名和学生身份证号作为新文件名

Sub AutoOpen()
UserForm1.ComboBox1.List = Array("doc文件", "docx文件", "docm文件")
End Sub
Sub 重命名()
Dim thispath$, myfile$, mydoc As Document, sr$, sf$
With Application.FileDialog(msoFileDialogFolderPicker)
   .InitialFileName = ActiveDocument.Path
   .Title = "选取待压缩文件位置"
   .ButtonName = "选定路径"
   If .Show = -1 Then SelPth = .SelectedItems(1)
End With
If Len(SelPth) > 0 Then thispath = SelPth & "\": pth = Left$(SelPth, InStrRev(SelPth, "\") - 1) & "\"
      On Error Resume Next
      MkDir pth & "命名后文档"
      On Error GoTo 0
myfile = Dir(thispath & "*.doc")
Select Case UserForm1.ComboBox1.Text
   Case "doc文件"
      hzh = ".doc"
      typ = wdFormatDocument
   Case "docx文件"
      hzh = ".docx"
      typ = wdFormatXMLDocument
   Case Else
      hzh = ".docm"
      typ = wdFormatXMLDocumentMacroEnabled
End Select
Do While myfile <> ""
If myfile <> ActiveDocument.Name Then
      Set mydoc = Documents.Open(thispath & myfile)
      sr = mydoc.Tables(1).Cell(1, 3).Range.Text
      sr = Replace(Replace(sr, " ", ""), Chr(13) & Chr(7), "")
      sf = mydoc.Tables(1).Cell(3, 3).Range.Text
      sf = Replace(Replace(sf, " ", ""), Chr(13) & Chr(7), "")
      targetstr = pth & "命名后文档\" & sr + sf & hzh
      mydoc.SaveAs2 targetstr, FileFormat:=typ
      If UserForm1.CheckBox1.Value = True Then
         mydoc.ExportAsFixedFormat OutputFileName:=pth & "命名后文档\" & sr + sf & ".pdf", ExportFormat:=wdExportFormatPDF '转为pdf格式文件
      End If
      mydoc.Close 0
End If
myfile = Dir
Loop
End Sub

尕司令 · 发表于 2022-3-22 10:57

Sub AutoOpen()
UserForm1.ComboBox1.List = Array("doc文件", "docx文件", "docm文件")
End Sub
Sub 重命名()
Dim thispath$, myfile$, mydoc As Document, sr$
With Application.FileDialog(msoFileDialogFolderPicker)
   .InitialFileName = ActiveDocument.Path
   .Title = "选取待压缩文件位置"
   .ButtonName = "选定路径"
   If .Show = -1 Then SelPth = .SelectedItems(1)
End With
If Len(SelPth) > 0 Then thispath = SelPth & "\": pth = Left$(SelPth, InStrRev(SelPth, "\") - 1) & "\"
      On Error Resume Next
      MkDir pth & "命名后文档"
      On Error GoTo 0
myfile = Dir(thispath & "*.doc")
Select Case UserForm1.ComboBox1.Text
   Case "doc文件"
      hzh = ".doc"
      typ = wdFormatDocument
   Case "docx文件"
      hzh = ".docx"
      typ = wdFormatXMLDocument
   Case Else
      hzh = ".docm"
      typ = wdFormatXMLDocumentMacroEnabled
End Select
Do While myfile <> ""
If myfile <> ActiveDocument.Name Then
      Set mydoc = Documents.Open(thispath & myfile)
      sr = mydoc.Tables(1).Cell(2, 3).Range.Text
      sr = Replace(Replace(sr, " ", ""), Chr(13) & Chr(7), "")
      targetstr = pth & "命名后文档\" & sr & hzh
      mydoc.SaveAs2 targetstr, FileFormat:=typ
      If UserForm1.CheckBox1.Value = True Then
         mydoc.ExportAsFixedFormat OutputFileName:=pth & "命名后文档\" & sr & ".pdf", ExportFormat:=wdExportFormatPDF '转为pdf格式文件
      End If
      mydoc.Close 0
End If
myfile = Dir
Loop
End Sub

尕司令 · 发表于 2022-3-22 21:23

蜀中草莽发表于 2022-3-9 11:31
Sub AutoOpen()
UserForm1.ComboBox1.List = Array("doc文件", "docx文件", "docm文件")
End Sub

改过后可以完美运行但是又出现一个问题假如提取到两个文件身份证号和姓名都是一样如何不进行覆盖处理第一次出现的在身份证后加1 第二次加2 第三次加3 不希望被覆盖掉

尕司令 · 发表于 2022-3-22 21:27

蜀中草莽发表于 2022-3-9 09:10
建议在源数据表加一列辅助列姓名+身份证号作为命名依据，然后合并到不同的新文档，以辅助列命名！

申请表没有数据源是系统导出下载下来的会出现同一个人的资料下载多次的情况但是不希望重命名的时候覆盖掉因为提取到身份证号和姓名都是一样的但是不知道哪个是修改过的所以希望改名后以副本形式出现

		自动登录	找回密码
密码			免费注册

[求助] 按照WORD内容批量修改文件名

评分