[已解决]修改工作薄名称的问题

dfshm

附件 批量改工作薄名.rar (77.96 KB, 下载次数: 7)

2017-7-10 16:09 上传

点击文件名下载附件
谢谢！

最佳答案

月排行榜 / 总排行榜

chart888

2017-7-10 16:40

1. Private Sub CommandButton1_Click()
   
2. Dim fs, f, f1, fc, s, name1, name2
   
3. Application.DisplayAlerts = False
   
4. Application.ScreenUpdating = False
   
5. Set fs = CreateObject("Scripting.FileSystemObject")
   
6. pth = ThisWorkbook.Path & ""
   
7. AA = ThisWorkbook.ActiveSheet.Cells(1, 1)
   
8. Set f = fs.GetFolder(pth)
   
9. Set fc = f.Files
   
10. MkDir pth & "New"
    
11. For Each f1 In fc
    
12.     If f1.Name Like "*.xlsx" Then
    
13.         name1 = Split(f1.Name, ".")(0)
    
14.         name2 = name1 + AA
    
15.         Workbooks.Open f1
    
16.         With ActiveWorkbook
    
17.             .SaveAs pth & "New" & name2 & ".xlsx"
    
18.             .Close
    
19.             Kill f1
    
20.         End With
    
21.     End If
    
22. Next
    
23. Application.DisplayAlerts = True
    
24. Application.ScreenUpdating = True
    
25. End Sub

复制代码

跳转到最佳答案楼层

chart888

1. Private Sub CommandButton1_Click()
   
2. Dim fs, f, f1, fc, s, name1, name2
   
3. Application.DisplayAlerts = False
   
4. Application.ScreenUpdating = False
   
5. Set fs = CreateObject("Scripting.FileSystemObject")
   
6. pth = ThisWorkbook.Path & ""
   
7. AA = ThisWorkbook.ActiveSheet.Cells(1, 1)
   
8. Set f = fs.GetFolder(pth)
   
9. Set fc = f.Files
   
10. MkDir pth & "New"
    
11. For Each f1 In fc
    
12.     If f1.Name Like "*.xlsx" Then
    
13.         name1 = Split(f1.Name, ".")(0)
    
14.         name2 = name1 + AA
    
15.         Workbooks.Open f1
    
16.         With ActiveWorkbook
    
17.             .SaveAs pth & "New" & name2 & ".xlsx"
    
18.             .Close
    
19.             Kill f1
    
20.         End With
    
21.     End If
    
22. Next
    
23. Application.DisplayAlerts = True
    
24. Application.ScreenUpdating = True
    
25. End Sub

复制代码

dfshm

chart888 发表于 2017-7-10 16:40

老师你好，谢谢帮助。试了一下，很慢。因为工作薄很大，每个都超过100M，如果边改边移动到  新文件夹  速度就慢了。如果就地改，不移动到  新的文件夹，速度会飞快。
不知能否修改一下？谢谢了。

chart888

dfshm 发表于 2017-7-11 09:19
老师你好，谢谢帮助。试了一下，很慢。因为工作薄很大，每个都超过100M，如果边改边移动到  新文件夹  速 ...

1. Private Sub CommandButton1_Click()
   
2. Dim fs, f, f1, fc, s, name1, name2
   
3. Application.DisplayAlerts = False
   
4. Application.ScreenUpdating = False
   
5. Set fs = CreateObject("Scripting.FileSystemObject")
   
6. pth = ThisWorkbook.Path & ""
   
7. AA = ThisWorkbook.ActiveSheet.Cells(1, 1)
   
8. Set f = fs.GetFolder(pth)
   
9. Set fc = f.Files
   
10. For Each f1 In fc
    
11.     If f1.Name Like "*.xlsx" Then
    
12.         name1 = Split(f1.Name, ".")(0)
    
13.         name2 = name1 + AA
    
14.         Workbooks.Open f1
    
15.         With ActiveWorkbook
    
16.             .SaveAs pth & name2 & ".xlsx"
    
17.             .Close
    
18.             Kill f1
    
19.         End With
    
20.     End If
    
21. Next
    
22. Application.DisplayAlerts = True
    
23. Application.ScreenUpdating = True
    
24. End Sub

复制代码

不移动还是挺慢的我感觉
你再试试呢

dfshm

chart888 发表于 2017-7-11 09:31
不移动还是挺慢的我感觉
你再试试呢

修改49个工作薄名称，应该不会超过20秒。我以前接触过类似命题，可惜找不到了。