重命名工作表，同时复制到另一个文件

我使用macros将大量的表单复制到一个Excel文件中。 macros是来自一个旧的项目，所以它需要一些调整。 它看起来像这样：

Sub CombineSheets() Dim sPath As String Dim sFname As String Dim wBk As Workbook Dim wSht As Variant Application.EnableEvents = False Application.ScreenUpdating = False sPath = InputBox("Enter a full path to workbooks") ChDir sPath sFname = InputBox("Enter a filename pattern") sFname = Dir(sPath & "\" & sFname & ".xl*", vbNormal) wSht = InputBox("Enter a worksheet name to copy") Do Until sFname = "" Set wBk = Workbooks.Open(sFname) Windows(sFname).Activate Sheets(wSht).Copy Before:=ThisWorkbook.Sheets(1) wBk.Close False sFname = Dir() Loop ActiveWorkbook.Save Application.EnableEvents = True Application.ScreenUpdating = True End Sub 

我需要的是一种方法来重命名我复制的工作表，insten的工作表名称从原始文件，我希望它被重命名为文件名，或将文件名添加到工作表名称。

Answer 1

不要评论你的旧macros代码（我个人不喜欢Windows(sFname).Activate但只要它工作正常），这是怎么做才能改变表名称：

 Sub CombineSheets() Dim sPath As String Dim sFname As String Dim wBk As Workbook Dim wSht As Variant Application.EnableEvents = False Application.ScreenUpdating = False sPath = InputBox("Enter a full path to workbooks") ChDir sPath sFname = InputBox("Enter a filename pattern") sFname = Dir(sPath & "\" & sFname & ".xl*", vbNormal) wSht = InputBox("Enter a worksheet name to copy") Do Until sFname = "" Set wBk = Workbooks.Open(sFname) Windows(sFname).Activate Sheets(wSht).Copy Before:=ThisWorkbook.Sheets(1) 'add this line --v ThisWorkbook.Sheets(1).Name = "stack" & Replace(Time, ":", "") 'this line is added --^ wBk.Close False sFname = Dir() Loop ActiveWorkbook.Save Application.EnableEvents = True Application.ScreenUpdating = True End Sub 

请注意，如果您尝试保存多个工作表时，循环速度太快，则可能会出现错误，因为名称会相同。 因此，为这个名字引入一个计数器是一个明智的想法。