自动将每个工作簿中的各个工作表更名，更改后的工作表名称=工作簿的名称+原工作表的名称，如何编写宏代码

问题是这样的，我现在电脑里有一个文件夹，这个文件夹里面存放了多个excel工作簿文件，每个excel工作簿文件里面都包含有多个工作表，我现在想实现的是：自动将每个工作簿中的各个工作表更名，更改后的工作表名称=工作簿的名称+原工作表的名称，如何编写宏代码，使该项工作一次完成。即：只运行一次宏代码，就能使所有工作簿中的工作表都完成更名。望高手赐教

新建一个工作簿，把代码复制进去，然后运行就好了。

新建工作簿和要更名的工作簿放同一个文件夹下即可。
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

1:先在a1单元格中输入1日酸洗，再在a2单元格中输入1日分条。2：框选a1和a2单元格，鼠标指针放在a2单元格的右下角往下拉，以序列方式填充！就像图片1样