如何将多个工作簿中的多个工作表重命名，更名为“工作簿名称+原工作表名称“

≡v≡

将多个工作簿内的工作表全部拆分到一块，但是因为工作表名称都一样，所以得提前更名。找了一下午，找到一个代码，但是只对当工作簿起作用。见下面代码。再附上附件
Sub Rename()
Dim str, Filename, wb, sht, ke, dic, dic2
Dim rng As Range, firstadd, MyFileName
Dim lujing As String
Set dic = CreateObject("Scripting.Dictionary")
lujing = Left(ActiveWorkbook.FullName, InStrRev(ActiveWorkbook.FullName, "\"))
MyFileName = Dir(lujing & "*.xlsx") '这里修改文件类型,03版改为.xls就好了。
Do While MyFileName <> ""
    dic(lujing & "\" & MyFileName) = MyFileName
    MyFileName = Dir
Loop
For Each ke In dic.keys
    Set wb = GetObject(ke)
    With wb
        For Each sht In .Worksheets
            sht.name=.name & sht.name
        Next
    End With
    wb.save
    wb.close
    set wb=nothing
Next
End Sub

≡v≡

不知道有没有说清楚，就是有001、002等工作簿，里面有a、b、c等工作表，我需要把a、b、c分别更名为001a、001b、001c和002a、002b、002c这样子

huang1314wei

目测代码写的没有问题，不知道楼主是怎么运行的，出现什么问题也不说，你是把代码复制到哪里运行呢？

≡v≡

huang1314wei 发表于 2016-9-25 07:29
目测代码写的没有问题，不知道楼主是怎么运行的，出现什么问题也不说，你是把代码复制到哪里运行呢？

你好，谢谢回复。我刚才又仔细检查了下， 原来是文件名太长了= =。但是现在又发现，只有当前工作簿的工作表才会更名，对文件夹内的其他工作簿不起作用。代码能实现这个吗？

huang1314wei

≡v≡ 发表于 2016-9-25 13:14
你好，谢谢回复。我刚才又仔细检查了下， 原来是文件名太长了= =。但是现在又发现，只有当前工作簿的工作 ...

你需要注意xls和xlsx的区别

≡v≡

huang1314wei 发表于 2016-9-25 13:42
你需要注意xls和xlsx的区别

注意到了，代码里改成xls了，文件夹内也都是xls，但是只对当前工作簿起作用。

huang1314wei

≡v≡ 发表于 2016-9-25 14:45
注意到了，代码里改成xls了，文件夹内也都是xls，但是只对当前工作簿起作用。

代码给你改一下

Sub Rename()
Dim str, Filename, wb, sht, ke, dic
Dim rng As Range, firstadd, MyFileName
Dim lujing As String
Set dic = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
lujing = Left(ActiveWorkbook.FullName, InStrRev(ActiveWorkbook.FullName, "\"))
MyFileName = Dir(lujing & "*.xls") '这里修改文件类型,03版改为.xls就好了。
Do While MyFileName <> ""
    If MyFileName <> ThisWorkbook.Name Then
        dic(lujing & MyFileName) = ""
    End If
    MyFileName = Dir
Loop
For Each ke In dic.keys
    Set wb = Workbooks.Open(ke)
    With wb
        For Each sht In .Worksheets
            sht.Name = Left(.Name, Len(.Name) - 4) & sht.Name
        Next
    End With
    wb.Save
    wb.Close
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

jjmysjg

huang1314wei 发表于 2016-9-25 15:12
代码给你改一下

Sub Rename()

高手无所不能

≡v≡

huang1314wei 发表于 2016-9-25 15:12
代码给你改一下

Sub Rename()

已解决，非常感谢！

skygaoyan

解决的好快啊  大师们 看下我的帖子做个小程序 可以吗？