Bom dia a todos , vou usar este código na planilha anexa ,

Sub Gerar_Programação()

 Dim Nome, NomeCopia As String
Dim UltLinha As Long
Desprot
    Rows("99:99").Select
    Selection.AutoFilter
    ActiveWindow.ScrollColumn = 1
    ActiveSheet.Range("$A$99:$A$5000").AutoFilter Field:=3, Criteria1:="S"
    
    UltLinha = ActiveSheet.Range("C65000").End(xlUp).Row + 1
    
    Cid = Range("A100").Value
    Alim = Range("B100").Value
    Disposit = Range("F68").Value
    Reexibir_Para_Edição
     
   ActiveSheet.Range("D100:G" & UltLinha & " , I100:I" & UltLinha & ",T100:T" & UltLinha & ",W100:W" & _
   UltLinha & ",Z100:Z" & UltLinha & ",AB100:AD" & UltLinha & ",AF100:AF" & UltLinha & ",AI100:AI" & _
   UltLinha & ",AL100:AL" & UltLinha & ",AN100:AN" & UltLinha & ",AP100:AQ" & UltLinha).Select
   
  Selection.Copy
  
  
  Nome = ActiveWorkbook.Name
  
       NomeCopia = "Executar " & Left(ActiveSheet.Name, Len(ActiveSheet.Name))
          Workbooks.Add
              
    Range("A3").Select
   ActiveSheet.Paste
   
   somat = ActiveSheet.Range("E65000").End(xlUp).Row + 1
   Range("A1").Value = "Cidade:"
   Range("B1").Value = Cid
   Range("D1").Value = "Dispositivo_Aliment.:"
   Range("E1").Value = Disposit & "_" & Alim
   Range("K1").Value = "Executor/Data:"
   Range("A2").Value = "Ponto 1"
   Range("A2").Value = "Ponto 1"
   Range("B2").Value = "Ponto 2"
   Range("C2").Value = "Coord. do Ponto1"
   Range("D2").Value = "Coord. do Ponto2"
   Range("E2").Value = "US's"
   Range("F2").Value = "Faixa 10M"
   Range("G2").Value = "Faixa 15M"
   Range("H2").Value = "Abertura "
   Range("I2").Value = "Bambu M²"
   Range("J2").Value = "Aceiro"
   Range("K2").Value = "Cerca Viva"
   Range("L2").Value = "Cipó"
   Range("M2").Value = "Podar Arv."
   Range("N2").Value = "Cortar Arv."
   Range("O2").Value = "Arv. Silvic."
   Range("P2").Value = "Arv. Silvic.   > Q 5"
   Range("Q2").Value = "Abert. Acesso"
   Range("R2").Value = "Observação"
   Range("D" & somat).Value = "Total em US's"
 
   Mesclar
   AjustarImpr
   AjustaBordas
   Ajustar
   
   Rows("1:1").RowHeight = 33
    
   Cells(somat, 5).Value = Application.WorksheetFunction.Sum(Range("E3:E" & somat))
   
Range("E" & somat & ":" & "H" & somat).Select
    Selection.Merge
    
     Range("E" & somat).Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = -0.149998474074526
        .PatternTintAndShade = 0
    End With
   
      ActiveWorkbook.SaveAs NomeCopia
   Range("A3").Select
   Windows(Nome).Activate
   Reexibir_Para_Edição
   Desprot
    Application.CutCopyMode = False
    Selection.AutoFilter
        ActiveSheet.Range("A100").Select
        Prot
End Sub

Porem na linha ; Workbooks.Add e ActiveWorkbook.SaveAs NomeCopia
Precisava que fosse o seguinte;
1- A "pasta de trabalho gerada" fosse com somente uma planilha e com o nome da planilha "original" e não Plan1 , Plan2 e Plan3 como está sendo.

2- O salvamento É em local não determinado(não sei nem qual o critério e onde esta sendo salvo). Existe como determinar no código que seja Verificado em C: se existe uma Pasta de Arquivos com o nome de Controle de Execução de Faixa ; caso haja , salvar dentro desta pasta de arquivos a "pasta de trabalho gerada" , se não houver a pasta de arquivos Controle de Execução de Faixa , então tomar a seguinte providencia Criar,Novo,Pasta de Arquivos e nomear com Controle de Execução de Faixa e então proceder o salvamento.

Para entender , no anexo; clicar em Gerar_Programação

Por hora muito obrigado a todos.