[已解决]以单元格内容批量重命名工作簿

sparkguo

以单元格内容批量重命名工作簿---更新.rar (29.58 KB, 下载次数: 137)

2011-11-14 16:37 上传

点击文件名下载附件 以前发了一个类似的帖子，没有解决问题，所以重新开贴，希望有人可以帮忙解决。
要求: 如果遇到sheet1 b3单元格内容相同  则工作簿名称后面加序号
如:附件中有两个文件 sheet1 b3单元格 都是dudu 此时工作簿名称命名为：dudu   dudu1 以示区分。

最佳答案

月排行榜 / 总排行榜

zjdh

2011-11-14 14:17

钻了牛角尖啦   已修改

1. Sub Macro1()
   
2.     Dim WK As Workbook, MyPath$, MyName$, NewNm$, Nm$, I%
   
3.     MyPath = ThisWorkbook.Path & "\需重命名工作簿"    '请自己修改路径
   
4.     MyName = Dir(MyPath & "*.xls")
   
5.     Application.ScreenUpdating = False
   
6.     Do While MyName <> ""                                      '先登记一下已有文件
   
7.         Nm = Nm & "|" & Left(MyName, Len(MyName) - 4)
   
8.         MyName = Dir
   
9.     Loop
   
10.     MyName = Dir(MyPath & "*.xls")
    
11.     Do While MyName <> ""
    
12.         Set WK = GetObject(MyPath & MyName)
    
13.         NewNm = WK.Sheets(1).[b3]
    
14.         NewNm2 = WK.Sheets(1).[b3]
    
15.         For I = 1 To 100                               '预估最大101个同名
    
16.             If InStr(Nm, NewNm2) Then NewNm2 = NewNm & I
    
17.         Next
    
18.         Nm = Nm & "|" & NewNm2
    
19.         WK.Close False
    
20.         Name MyPath & MyName As MyPath & NewNm2 & ".xls"
    
21.         MyName = Dir
    
22.     Loop
    
23.     Application.ScreenUpdating = True
    
24.     MsgBox "修改完毕"
    
25. End Sub
    

复制代码

跳转到最佳答案楼层

zjdh

钻了牛角尖啦   已修改

1. Sub Macro1()
   
2.     Dim WK As Workbook, MyPath$, MyName$, NewNm$, Nm$, I%
   
3.     MyPath = ThisWorkbook.Path & "\需重命名工作簿"    '请自己修改路径
   
4.     MyName = Dir(MyPath & "*.xls")
   
5.     Application.ScreenUpdating = False
   
6.     Do While MyName <> ""                                      '先登记一下已有文件
   
7.         Nm = Nm & "|" & Left(MyName, Len(MyName) - 4)
   
8.         MyName = Dir
   
9.     Loop
   
10.     MyName = Dir(MyPath & "*.xls")
    
11.     Do While MyName <> ""
    
12.         Set WK = GetObject(MyPath & MyName)
    
13.         NewNm = WK.Sheets(1).[b3]
    
14.         NewNm2 = WK.Sheets(1).[b3]
    
15.         For I = 1 To 100                               '预估最大101个同名
    
16.             If InStr(Nm, NewNm2) Then NewNm2 = NewNm & I
    
17.         Next
    
18.         Nm = Nm & "|" & NewNm2
    
19.         WK.Close False
    
20.         Name MyPath & MyName As MyPath & NewNm2 & ".xls"
    
21.         MyName = Dir
    
22.     Loop
    
23.     Application.ScreenUpdating = True
    
24.     MsgBox "修改完毕"
    
25. End Sub
    

复制代码

zjdh

有问题删了

wayy

zjdh 发表于 2011-11-14 15:47

1. Sub Macro1()
   
2. Dim wb As Workbook, MyPath As String, MyName As String
   
3. MyPath = ThisWorkbook.Path & "\需重命名工作簿" '请自己修改路径
   
4. MyName = Dir(MyPath & "*.xls")
   
5. Application.ScreenUpdating = False
   
6. Do While MyName <> ""
   
7. Set WK = GetObject(MyPath & MyName)
   
8. NewNm = WK.Sheets(1).[b3]
   
9. For I = 1 To 100 '预估最大101个同名
   
10. If InStr(Nm, NewNm) Then
    
11. NewNm = NewNm & I
    
12. Exit For
    
13. Else
    
14. Nm = Nm & "|" & NewNm
    
15. Exit For
    
16. End If
    
17. Next
    
18. WK.Close False
    
19. Name MyPath & MyName As MyPath & NewNm & ".xls"
    
20. MyName = Dir
    
21. Loop
    
22. Application.ScreenUpdating = True
    
23. MsgBox "修改完毕"
    
24. End Sub

复制代码

代码不错，学习了。

sparkguo

zjdh 发表于 2011-11-14 15:47

谢谢老师的帮忙，  
但sheet1 B3  内容相同的文件如果三个以上则会报错   

zjdh

再看看         .

sparkguo

zjdh 发表于 2011-11-14 16:00
修改啦：

请以此附件进行测试  
麻烦了

sparkguo

zjdh 发表于 2011-11-14 16:25
钻了牛角尖啦

提示“ 运行时错误 58    文件已经存在”

zjdh

我就在想若原来就存在了会出错。
先登记一下吧。
7楼代码已修改。

sparkguo

zjdh 发表于 2011-11-14 16:39
我就在想若原来就存在了会出错。
先登记一下吧。
7楼代码已修改。

7楼的代码   第一次执行  可以达到要求    同样的代码连续执行1次以上   工作簿的名称发生了变化  竟然不一样  奇怪