Копировать конкретные имена листов из диапазона

Question

Мне нужна помощь, и я надеюсь, что кто-то здесь может мне помочь:)

У меня есть рабочая книга с отчетами из Avaya CMS. Он запускает отчет и создает новый лист для каждого имени человека на главном листе. << Эта часть прекрасно работает. </p>

Моя проблема в том, что я не могу понять, как использовать этот диапазон имен на ГЛАВНОМ листе, чтобы выбрать только эти конкретные листы, а затем скопировать их в новую рабочую книгу. Есть также 2 других скрытых листа. Вот почему я думаю, что использовать диапазон имен проще, но я открыт для всего на данный момент.

Вот скриншот того, как это выглядит:

Извините, я не могу понять, как загрузить рабочую книгу сюда, но, надеюсь, изображение должно быть достаточно хорошим. Спасибо за ваше время и помощь!

Вот изображение со скрытыми листами.

Мне нужно, чтобы исключить первые 3 листа /

А вот код:

Sub Macro1()
    Dim sheetArray() As String
    Dim i As Integer
    i = 0

    For Each c In MainSheet.Range("A2:A20").Cells
        ReDim Preserve sheetArray(0 To i)
        sheetArray(i) = c.Value
        i = i + 1
    Next
    Sheets(sheetArray).Select
End Sub

Answer 1

Вы можете попробовать:

Option Explicit

Sub test()

    Dim LastRow As Long, i As Long, sheetIndex As Long
    Dim SheetName As String
    Dim ws As Worksheet

    With ThisWorkbook.Worksheets("Main")

        'Last row of column where the names appears
        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

    'Loop the column from row 2 to last row
        For i = 2 To LastRow

            'Set Sheet name
            SheetName = .Range("A" & i).Value

            'Check if the sheet with the SheetName exists
            If DoesSheetExists(SheetName) Then
                'Insert the code to code
                sheetIndex = Workbooks("Book2").Sheets.Count
                ThisWorkbook.Worksheets(SheetName).Copy After:=Workbooks("Book2").Sheets(sheetIndex)
            Else

            End If

        Next i

    End With

End Sub

Function DoesSheetExists(SheetName As String) As Boolean

    Dim ws As Worksheet

    On Error Resume Next
    Set ws = ThisWorkbook.Sheets(SheetName)
    On Error GoTo 0

    If Not ws Is Nothing Then DoesSheetExists = True

End Function

Answer 2

Sub move_Sheets()

Dim mSH As Worksheet
Set mSH = ThisWorkbook.Sheets("Main")

Dim shArray() As String
Dim i As Integer
i = mSH.Range("A" & Rows.Count).End(xlUp).Row
ReDim Preserve shArray(0 To i - 2)

For a = 2 To i
    shArray(a - 2) = mSH.Range("A" & a).Value
Next a

ThisWorkbook.Sheets(shArray).Move

End Sub