​​如何利用VBA一键更改多个excel文件为指定的名称!

 

问题：如何一键更改相同目录下的所有excel文件的名称，改为这个excel文件名内的每个单元格的内容，如我这个因为是要统计所有比赛队伍的信息，因为大部分人的excel文件名都不规范，这样如果有人想更新文件就得在文件夹里一个一个找很麻烦，就直接把每个队伍的文件命名为他的比赛项目名，这样在一定程度上就具有唯一性

解决：首先把所有要整合的excel文件放在一个路径不含有中文名的目录下，然后新建一个excel文件右键sheet点击查看代码，这时候你的画面上会出现一个编辑器，你这这上面利用VBA编写语言，最后点击F5直接运行即可

常规解决方案：
打开文件，复制项目名，关闭文件，重命名

利用VBA一键修改：

1. 得到全是英文目录下的一个文件名

1. 打开这个文件

1. 得到这个文件对应的项目名

1. 推出并关闭这个文件

1. 重命名这个文件

1. 因为这个项目名可能会出现很多windows的非法字符所以要利用replace函数出去一下

7. 而且还会出现许多不知名的错误，比如说重名，没写项目名等，这样就要使用的VBA的错误处理机制

源码如下：

Sub 批量改名()

Dim mypath As String, myname As String, awbname As String, arg As String

Dim wbcount As Integer, i As Integer

Dim olds As String, news As String

'关闭excel的刷新

Application.ScreenUpdating = False

'禁止弹出对话框

Application.DisplayAlerts = False

'得到本文件的相对地址

mypath = ActiveWorkbook.Path

'当前工作的excel的文件名

awbname = ActiveWorkbook.Name

'任意打开文件夹下的某一个文件

wbcount = 0

myname = Dir(mypath & "" & "*.xlsx")

'定义一个变量为项目的名称（文件中的命名）

arg = ""

'如果当前的文件名为空的字符串（""）表示已经没有更多的文件了跳出循环

Do While myname <> ""

If myname <> awbname Then

'打开当前的文件夹

Set wb = Workbooks.Open(mypath & "" & myname)

'得到这个文件的项目名的名称

arg = wb.Sheets(1).Range("B5")

wbcount = wbcount + 1

'关闭文件

wb.Close False

'除去arg中命名规则不允许的字符

arg = Replace(arg, "", "")

arg = Replace(arg, " ", "")

arg = Replace(arg, "/", "")

arg = Replace(arg, "?", "")

arg = Replace(arg, "<", "")

arg = Replace(arg, ">", "")

arg = Replace(arg, "'", "")

arg = Replace(arg, ":", "")

arg = Replace(arg, "*", "")

arg = Replace(arg, """", "")

arg = Replace(arg, ".", "")

arg = Replace(arg, "|", "")

arg = Replace(arg, Chr(10), "")

arg = Replace(arg, Chr(32), "")

olds = mypath & "" & myname

news = mypath & "" & arg & ".xlsx"

'将这个文件的名称换成这个项目名

On Error GoTo MyErr '错误导向

Name olds As news

End If

'随机打开本文件夹的另一个文件

myname = Dir

Loop

'结束程序并且恢复之前的操作

MsgBox "一共更改了 " & wbcount & " 个文件"

Application.ScreenUpdating = True

Application.DisplayAlerts = True

'因为这个VBA语言到最后会运行错误标志的内容所以在结束后要让他失效

olds = ""

'错误标志

MyErr:

If olds = "" Then

Else

arg = arg & wbcount

news = mypath & "" & arg & ".xlsx"

Name olds As news

Resume Next

End If

End Sub

如果大家有其他的方法，或者想要知道哪方面的办公技巧，下方评论哦~

学习资料见知识星球。

以上就是今天要分享的技巧，你学会了吗？若有什么问题，欢迎在下方留言。

快来试试吧，小琥 my21ke007。获取 1000个免费 Excel模板福利​​​​！

更多技巧， www.excelbook.cn

欢迎 加入 零售创新 知识星球，知识星球主要以数据分析、报告分享、数据工具讨论为主；

1、价值上万元的专业的PPT报告模板。

2、专业案例分析和解读笔记。

3、实用的Excel、Word、PPT技巧。

4、VIP讨论群，共享资源。

5、优惠的会员商品。

6、一次付费只需99元，即可下载本站文章涉及的文件和软件。