VBA: если имя рабочего листа в рабочей книге равно значению поля со списком, выбранному из пользовательской формы, скопируйте этот рабочий лист и вставьте его в другую рабочую книгу

Question

Я работаю над пользовательской формой, которая скопирует конкретный лист из рабочей книги A и вставит его в рабочую книгу B (по сути, архивируя эти данные).Пользовательская форма предоставляет пользователю выпадающий список со списком, чтобы выбрать имя листа для копирования.Однако я получаю сообщение об ошибке вне диапазона при использовании команды sheet.copy.Вот мой код с именами, измененными для удобства чтения:

    Dim ws as Worksheet
    Dim WorkbookA as Workbook
    Dim WorkbookB as Workbook
    Dim ComboBoxValue as String


    Set WorkbookA as ActiveWorkbook
    Set WorkbookB as Workbook.Open("C:File Path Here")

    With ThisWorkbook
        For Each ws In Application.ActiveWorkbook.Worksheets
            If ws.Name = UserForm1.ComboBox1.Text Then
                ComboBoxValue = ws.Name
                Worksheets(ComboBoxValue).Copy _ 
                After:=Workbooks("Workbook B.xlsm").Sheets(Sheets.Count) 
                ' Run-Time 9 Subscript Out of Range Error occurs on line above ^
                ActiveSheet.Name = UserForm1.ComboBoxSelection.Text
                WorkbookB.Save
                WorkbookB.Close
                WorkbookA.Activate
                Application.CutCopyMode = False
            End If
        Next ws
    End With

Answer 1

Изменить Sheets(Sheets.Count) на Sheets(Workbooks("Workbook B.xlsm").Sheets.Count)

В этом контексте Sheets(Sheets.Count) относится к исходному объекту рабочей книги, поэтому вы должны указать количество листов в другой книге.

Answer 2

Корень вашей ошибки - неправильное реферинг рабочей книги.Также есть много других проблем.

• Неосновная ссылка на ThisWorkbook
• Необязательный цикл по всем рабочим листам
• Неосновное переименование скопированного листа
• Unnecassry / неправильные ссылки на ActiveWorkbook и ActiveSheet
• Нет обработки ошибок
• Неправильный отступ

Ваш код подвергся рефакторингу.Это записывается как событие нажатия кнопки в пользовательской форме.Обновление в соответствии с вашими потребностями.

Option Explicit

Const ArchiveFilePath As String = "C:\Path\To\ArchiveBook.xlsx"

Private Sub CommandButton1_Click()
    Dim ws As Worksheet
    Dim WorkbookA As Workbook
    Dim WorkbookB As Workbook
    Dim wsName As String

    Application.ScreenUpdating = False

    Set WorkbookA = ActiveWorkbook

    wsName = UserForm1.ComboBox1.Text
    If wsName = vbNullString Then Exit Sub

    On Error Resume Next 'Handle possibility that Open fails
    Set WorkbookB = Workbooks.Open(ArchiveFilePath)
    On Error GoTo 0
    If WorkbookB Is Nothing Then
        MsgBox "Failed to open " & ArchiveFilePath, vbOKOnly, "Error"
        Exit Sub
    End If

    'Check if specified ws already exists in WorkbookB
    Set ws = GetWorksheet(WorkbookB, wsName)
    If Not ws Is Nothing Then
        ' Sheet already exists.  What now?
        MsgBox "Sheet " & wsName & " already exists in " & WorkbookB.Name & ".  What now?", vbOKOnly, "Error"
        WorkbookB.Close
        Exit Sub
    End If

    Set ws = GetWorksheet(WorkbookA, wsName)
    If ws Is Nothing Then
        MsgBox "Sheet " & wsName & " does not exist in " & WorkbookA.Name, vbOKOnly, "Error"
        WorkbookB.Close
        Exit Sub
    End If

    ws.Copy After:=WorkbookB.Sheets(WorkbookB.Sheets.Count)

    WorkbookB.Save
    WorkbookB.Close

    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

Private Function GetWorksheet(wb As Workbook, wsName As String) As Worksheet
    On Error GoTo EH
    Set GetWorksheet = wb.Worksheets(wsName)
EH:
End Function