Как я могу переименовать листы при комбинировании рабочих книг?

Question

Мне нужно объединить книги из папки, и я нашел приведенный ниже код, который должен делать именно то, что мне нужно.Код взят из здесь .

Проблема, с которой я сталкиваюсь, состоит в том, что все рабочие листы в моих рабочих книгах имеют одинаковое длинное название, и кажется, что 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

Answer 1

Основываясь на ответе 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

Answer 2

Используйте переменную 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 уже будет использован.Если это проблема, вы можете переименовать листы в corrospond с количеством листов в книге (wb1.Sheets.Count)