Boa noite!!
Eu creio não ter entendi o que você precisa
Até que sua resposta seja de acordo como precisa tente isso

Sub AddSheet()

'Adiciona uma guia com o nome na InputBox
Dim shName As String
shName = InputBox("Por favor digite o nome da Planilha")
If shName <> "" Then

Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = shName
End If
End Sub

Assim eu tenho uma planilha do Excel com 340 abas e entre elas quero gerar um novo arquivo (fazer copia de 10 abas para gerar um arquivo novo).

Bom dia!!

Isso deve te ajudar, porém deve adaptar!
Fonte: http://www.vbaexpress.com/kb/getarticle.php?kb_id=359

Option Explicit 
 
Sub TwoSheetsAndYourOut() 
    Dim NewName As String 
    Dim nm As Name 
    Dim ws As Worksheet 
     
    If MsgBox("Copy specific sheets to a new workbook" & vbCr & _ 
    "New sheets will be pasted as values, named ranges removed" _ 
    , vbYesNo, "NewCopy") = vbNo Then Exit Sub 
     
    With Application 
        .ScreenUpdating = False 
         
         '       Copy specific sheets
         '       *SET THE SHEET NAMES TO COPY BELOW*
         '       Array("Sheet Name", "Another sheet name", "And Another"))
         '       Sheet names go inside quotes, seperated by commas
        On Error Goto ErrCatcher 
        Sheets(Array("Copy Me", "Copy Me2")).Copy 
        On Error Goto 0 
         
         '       Paste sheets as values
         '       Remove External Links, Hperlinks and hard-code formulas
         '       Make sure A1 is selected on all sheets
        For Each ws In ActiveWorkbook.Worksheets 
            ws.Cells.Copy 
            ws.[A1].PasteSpecial Paste:=xlValues 
            ws.Cells.Hyperlinks.Delete 
            Application.CutCopyMode = False 
            Cells(1, 1).Select 
            ws.Activate 
        Next ws 
        Cells(1, 1).Select 
         
         '       Remove named ranges
        For Each nm In ActiveWorkbook.Names 
            nm.Delete 
        Next nm 
         
         '       Input box to name new file
        NewName = InputBox("Please Specify the name of your new workbook", "New Copy") 
         
         '       Save it with the NewName and in the same directory as original
        ActiveWorkbook.SaveCopyAs ThisWorkbook.Path & "" & NewName & ".xls" 
        ActiveWorkbook.Close SaveChanges:=False 
         
        .ScreenUpdating = True 
    End With 
    Exit Sub 
     
ErrCatcher: 
    MsgBox "Specified sheets do not exist within this workbook" 
End Sub 

Pessoal boa tarde,

Consegui descobrir, se alguem precisar segue.

Sub Capa_Retângulodecantosarredondados1_2_Clique()
'
' Capa_Retângulodecantosarredondados1_2_Clique Macro
'

'
Sheets(Array("Medicos", "SUMARIO UNIDADE", "Exames", "Exames Pagador", "Receita por Especialidade", "Pacientes", "Pagadores")).Select
Sheets("Capa").Activate
Sheets(Array("Medicos", "SUMARIO UNIDADE", "Exames", "Exames Pagador", "Receita por Especialidade", "Pacientes", "Pagadores")).Copy
End Sub

Boa noite!!

Para manter o fórum organizado, caso esclarecido, por favor marque seu tópico como resolvido!!

Veja como em:
viewtopic.php?f=7&t=3784

Att