按每个工作簿内容批量重命名工作簿

xrdzl

求助：需要提取每个工作簿第一张工作表指定B4单元格内容作为工作簿名称。

ykcbf1100

文件重命名

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.9.16
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set fso = CreateObject("Scripting.FileSystemObject")
   
5.     p = ThisWorkbook.Path & ""
   
6.     For Each f In fso.GetFolder(p).Files
   
7.         If LCase(f.Name) Like "*.xls*" Then
   
8.             If InStr(f, "~$") = 0 Then
   
9.                 If InStr(f, ThisWorkbook.Name) = 0 Then
   
10.                     Set wb = Workbooks.Open(f, 0)
    
11.                     fn = wb.Sheets(1).[b5].Value
    
12.                     wb.Close 0
    
13.                     f.Name = fn & "." & fso.GetExtensionName(f)
    
14.                 End If
    
15.             End If
    
16.         End If
    
17.     Next
    
18.     Application.ScreenUpdating = True
    
19.     MsgBox "OK！"
    
20. End Sub
    

复制代码

xrdzl

ykcbf1100 发表于 2024-9-16 20:47
文件重命名

非常感谢

jaxxcyh

1. Sub 提取指定工作表()
   
2.     Dim wb As Workbook
   
3.     Dim sht As Worksheet
   
4.    
   
5.     Application.DisplayAlerts = False
   
6.     For i = ThisWorkbook.Sheets.Count To 2 Step -1
   
7.         ThisWorkbook.Sheets(i).Delete
   
8.     Next
   
9.     Application.DisplayAlerts = True
   
10.    
    
11.     Dim myPath$
    
12.     With Application.FileDialog(msoFileDialogFolderPicker)
    
13.         If .Show Then myPath = .SelectedItems(1) Else Exit Sub
    
14.     End With
    
15.    
    
16.     Set fso = CreateObject("Scripting.FileSystemObject")
    
17.     For Each f In fso.GetFolder(myPath).Files
    
18.         If fso.getExtensionName(f.Name) = "xlsx" Or _
    
19.            fso.getExtensionName(f.Name) = "xls" Then
    
20.             Set wb = Workbooks.Open(myPath & "\" & f.Name)
    
21.             Set sht = wb.Sheets(1)
    
22.             sht.Copy after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
    
23.             ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name = sht.Range("B4").Value
    
24.             Set sht = Nothing
    
25.             wb.Close
    
26.         End If
    
27.     Next
    
28. End Sub
    

复制代码