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

Question

我正在使用宏将大量工作表复制到一个 Excel 文件中。该宏来自一个旧项目，因此需要进行一些调整。它看起来像这样：

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

我需要一种方法来重命名我复制的工作表，从原始文件中插入工作表名，我希望将其重命名为文件名，或者将文件名添加到工作表名。

Answer 1

不评论您的旧宏代码（我个人不喜欢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

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