合并工作簿时如何重命名工作表

>我需要合并文件夹中的工作簿，我找到了下面的代码，它应该完全符合我的需要。代码来自这里。

我遇到的问题是，我的工作簿中的工作表都具有相同的长标题，并且似乎使Sub崩溃，因为由于冲突，excel无法自动重命名工作表(例如，没有空间可以附加(2(和(3(等(。

如何在代码中添加任意重命名工作表的内容，例如复制 1、复制 2 等...... ？

Sub MergeWorkbooks()
Dim FolderName As String
Dim directory As String, fileName As String
Dim wb1 As Workbook, wb2 As Workbook
Dim ws As Worksheet
Set wb1 = Workbooks.Add
With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "Please select a folder."
    .AllowMultiSelect = False
    .Show
    On Error Resume Next
    FolderName = .SelectedItems(1)
    Err.Clear
    On Error GoTo 0
End With
directory = FolderName & ""
fileName = Dir(directory & "*.xls?")
Do While fileName <> ""
Set wb2 = Workbooks.Open(directory & fileName)
For Each ws In wb2.Sheets
    ws.Copy after:=wb1.Sheets(Sheets.Count)
Next ws
wb2.Close savechanges:=False
fileName = Dir
Loop
End Sub

使用变量i重命名工作表，然后再将其移至其他图书。i对应于该工作表在循环中来自的书籍。

因此，第 5 本书的工作表名称为 Sheet1 5，第 6 本书将Sheet1 6，依此类推，用于每本书中的每一张工作表。

Dim i As Long
i = 1
Do While Filename <> ""
    Set wb2 = Workbooks.Open(directory & Filename)
        For Each ws In wb2.Sheets
            ws.Name = ws.Name & Chr(32) & i               '<-- Rename
            ws.Copy after:=wb1.Sheets(Sheets.Count)
        Next ws
    wb2.Close savechanges:=False
    Filename = Dir
    i = i + 1                                             '<-- Increment i for next bok
Loop

这仅在代码运行一次时才有效 - 如果您尝试在具有相似名称的相同书籍上重新运行代码，则索引i已被使用。如果这是一个问题，您可以使用书上的纸张数(wb1.Sheets.Count(<</em>

div class="one_answers"重命名为腐蚀> 根据

urdearboy 的响应，我添加了用户提示，以选择是否需要批量重命名，如果是，则选择批处理名称。在需要时有选择真是太好了！

Sub MergeWorkbooks()
Dim FolderName As String
Dim directory As String, fileName As String
Dim wb1 As Workbook, wb2 As Workbook
Dim ws As Worksheet
Dim iAnswer As VbMsgBoxResult
Dim xAppend As String
Set wb1 = Workbooks.Add
With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "Please select a folder."
    .AllowMultiSelect = False
    .Show
    On Error Resume Next
    FolderName = .SelectedItems(1)
    Err.Clear
    On Error GoTo 0
End With
directory = FolderName & ""
fileName = Dir(directory & "*.xls?")
'Prompt user to decide if batch rename is required
iAnswer = MsgBox("Would you like to batch rename the worksheets?", vbYesNoCancel + vbQuestion + vbDefaultButton1, "Sort Worksheets")
    'vbYes: Rename Worksheets
    If iAnswer = vbYes Then
1:
        xAppend = InputBox(Prompt:= _
                    "Enter new batch name for worksheets." _
                    & vbNewLine & vbNewLine & _
                    "Sheets will be appended with number based on the order in which they are copied." _
                    & vbNewLine & vbNewLine & _
                    "If 'Cancel' is selected, worksheets will be renamed as number only, based on order in which they are copied.", _
                    Title:="Naming Convention")
                        If InStr(xAppend, "<") > 0 _
                            Or InStr(xAppend, ">") > 0 _
                            Or InStr(xAppend, ":") > 0 _
                            Or InStr(xAppend, Chr(34)) > 0 _
                            Or InStr(xAppend, "/") > 0 _
                            Or InStr(xAppend, "") > 0 _
                            Or InStr(xAppend, "|") > 0 _
                            Or InStr(xAppend, "?") > 0 _
                            Or InStr(xAppend, "*") > 0 _
                                 Then
                                    MsgBox "Suggested filename contains an invalid character"
                                    GoTo 1
                        End If
            Dim i As Long
            i = 1
            Do While fileName <> ""
                Set wb2 = Workbooks.Open(directory & fileName)
                    For Each ws In wb2.Sheets
                        ws.Name = xAppend & i                       '<-- Rename
                        ws.Copy after:=wb1.Sheets(Sheets.Count)
                    Next ws
                wb2.Close savechanges:=False
                fileName = Dir
                i = i + 1                                            '<-- Increment i for next bok
            Loop

        'vbNo: Rename Worksheets
        ElseIf iAnswer = vbNo Then
            Do While fileName <> ""
                Set wb2 = Workbooks.Open(directory & fileName)
                    For Each ws In wb2.Sheets
                        ws.Copy after:=wb1.Sheets(Sheets.Count)
                Next ws
            wb2.Close savechanges:=False
            fileName = Dir
            Loop
        'vb Canel: Exit
        Else
            Exit Sub
    End If
End Sub

相关内容

最新更新

热门标签：