关于批量修改文件名称问题

excelkill

根据编号查找文件夹下同名的pdf文件，然后按规则改名，并将该文件超链接添加到指定的单元格了，麻烦那位老师帮忙看看，非常感谢！

excelkill

上面的问题表述忘了一项，个人编号和姓名有重复数据的在重命名的时候，可以自动筛选选择一个就可以了

ykcbf1100

先标记一下。

liulang0808

Sub 改名()
Dim strFileName$, strPath$, wkb As Workbook
Dim brr, i&, R&, dic As Object
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
    strPath = ThisWorkbook.Path & "\名单\"
    strFileName = Dir(strPath & "*.pdf")
    While strFileName <> ""
        dic(strFileName) = ""
        strFileName = Dir
    Wend
    R = Cells(Rows.Count, "j").End(xlUp).Row
    brr = [a1].Resize(R, 12)
    For i = 1 To UBound(brr)
      If brr(i, 10) <> brr(i, 11) Then
        If dic.exists(brr(i, 11) & ".pdf") Then
            dic.Remove brr(i, 11) & ".pdf"
            f = "附件" & brr(i, 1) & "、" & brr(i, 10) & "的资料.pdf"
           Name strPath & brr(i, 11) & ".pdf" As strPath & f
           ActiveSheet.Hyperlinks.Add Anchor:=Cells(i, "y"), Address:=strPath & f, _
        TextToDisplay:=f
        End If
      End If
    Next i
    Application.ScreenUpdating = True
    Beep
End Sub

liulang0808

新建文件夹 (3).zip (43.12 KB, 下载次数: 3)

2024-2-5 18:56 上传

点击文件名下载附件

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.2.5
   
2.     Set Fso = CreateObject("scripting.filesystemobject")
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Application.ScreenUpdating = False
   
5.     Set sh = ThisWorkbook.Sheets("Sheet1")
   
6.     p = ThisWorkbook.Path & ""
   
7.     p1 = p & "名单"
   
8.     With sh
   
9.         R = .Cells(Rows.Count, "j").End(3).Row
   
10.         arr = .Range("a1:y" & R)
    
11.         For i = 2 To UBound(arr)
    
12.             s = CStr(arr(i, 11))
    
13.             fn = "附件" & arr(i, 1) & "、" & arr(i, 10) & "的文件材料"
    
14.             If Not d.exists(s) Then
    
15.                 d(s) = fn
    
16.             End If
    
17.             For Each f In Fso.GetFolder(p1).Files
    
18.                 If f.Name Like "*.pdf" Then
    
19.                     s = Fso.GetBaseName(f)
    
20.                     If d.exists(s) Then
    
21.                         f.Name = d(s) & ".pdf"
    
22.                     End If
    
23.                 End If
    
24.             Next f
    
25.             f = p1 & fn & ".pdf"
    
26.             .Hyperlinks.Add anchor:=.Cells(i, "y"), Address:=f
    
27.         Next
    
28.     End With
    
29.     Application.ScreenUpdating = True
    
30.     MsgBox "OK！"
    
31. End Sub
    

复制代码

ykcbf1100

附件供参考。。。

excelkill

ykcbf1100 发表于 2024-2-5 19:46
附件供参考。。。

老师，没分了，明天奉上