Olá omar,

Coloque a planilha para verificarmos,...

Leonardo, Boa tarde!

Segue exemplo, neste caso, gostaria de clicar em um botão salvar Pedido, onde criaria uma nova pasta de trabalho, contendo as abas Cosméticos, Vestuário e Informática(Copiadas), e esta seria salva em um determinado diretório com o nome do cliente.

Boa tarde omar,

Coloque esse código e atribua um botão a ele:

Option Explicit

Sub PlanilhaCliente()
Dim wsAtiva     As Worksheet
Dim fDlg        As FileDialog
Dim sArquivo    As String
Dim sNome       As String

    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    
    Set wsAtiva = ThisWorkbook.ActiveSheet
    Set fDlg = Application.FileDialog(FileDialogType:=msoFileDialogFolderPicker)
    
    If fDlg.Show = -1 Then
        sArquivo = fDlg.SelectedItems(1) & ""
    Else
        MsgBox "Não foi selecionada nenhuma pasta"
        GoTo final
    End If
    
    sNome = wsAtiva.Cells(3, 3).Value

    ActiveWorkbook.SaveCopyAs Filename:=sArquivo & sNome & ".xlsm"

    Workbooks.Open Filename:=sArquivo & wsAtiva.Cells(3, 3).Value & ".xlsm"
    ActiveWorkbook.Worksheets(1).Delete
    ActiveWorkbook.SaveAs FileFormat:=xlOpenXMLWorkbook
    ActiveWorkbook.Close

    MsgBox "Planilha criada com sucesso!" & vbNewLine & _
        "Nome da planilha: " & sNome & ".xlsx" & vbNewLine & _
        "Local da planilha: " & sArquivo

final:
    
    Set wsAtiva = Nothing
    Set fDlg = Nothing
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    
End Sub

Qualquer coisa da o grito.
Abraço

Obrigado Bernardo, porém ele esta criando uma cópia de toda pasta de trabalho, tem como ele não incluir na nova pasta a aba dados cliente?

Vê agora:

Option Explicit

Sub PlanilhaCliente()
Dim wsAtiva     As Worksheet
Dim fDlg        As FileDialog
Dim sArquivo    As String
Dim sNome       As String

    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    
    Set wsAtiva = ThisWorkbook.ActiveSheet
    Set fDlg = Application.FileDialog(FileDialogType:=msoFileDialogFolderPicker)
    
    If fDlg.Show = -1 Then
        sArquivo = fDlg.SelectedItems(1) & ""
    Else
        MsgBox "Não foi selecionada nenhuma pasta"
        GoTo final
    End If
    
    sNome = wsAtiva.Cells(3, 3).Value

    ActiveWorkbook.SaveCopyAs Filename:=sArquivo & sNome & ".xlsm"

    Workbooks.Open Filename:=sArquivo & wsAtiva.Cells(3, 3).Value & ".xlsm"
    ActiveWorkbook.Worksheets("Dados Cliente").Delete
    ActiveWorkbook.SaveAs FileFormat:=xlOpenXMLWorkbook
    ActiveWorkbook.Close

    MsgBox "Planilha criada com sucesso!" & vbNewLine & _
        "Nome da planilha: " & sNome & ".xlsx" & vbNewLine & _
        "Local da planilha: " & sArquivo

final:
    
    Set wsAtiva = Nothing
    Set fDlg = Nothing
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    
End Sub

omar,

Segue uma solução.

No aguardo.

Leonardo, este da erro de tempo de execução na linha abaixo:

'Nomeando as abas do arquivo novo
For a = 1 To QtdeAbas - 1
Workbooks(ArquivoCópia).Sheets(a).Name = NomeAba(a + 1)
Next

Não entendi é ou nao é pra constar os dados do cliente???

Não seira mais simples colocar tudo em uma unica aba, realizando assim um unico pedido????

Não tem pq separar o tipo de produto se o cliente é o mesmo.

omar,

Rode a macro passo a passo: Abrir o editor de macros usando o Alt + F11 e depois vá apertando o F8 para visualizar a execução da macro linha à linha.
Cada vez que passar pelo laço FOR / NEXT, verificar os valores das variáveis:

a
QtdeAbas
ArquivoCópias
NomeAba

Obs.: Para verificar os valores das variáveis, fique com a setinha do mouse sobre alguma variável, com isso, aparecerá o valor correspondente.

Veja se os valores fazem sentido, pois eu rodei novamente aqui e funcionou normalmente.

MPrudencio,

Esta planilha é modelo a original possui diversas abas que podem constar no novo arquivo salvo.

omar, tenta esse então:

Option Explicit

Sub PlanilhaCliente()
Dim wsAtiva     As Worksheet
Dim fDlg        As FileDialog
Dim sArquivo    As String
Dim sNome       As String
Dim Check       As String
Dim i           As Long

    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    
    Set wsAtiva = ThisWorkbook.ActiveSheet
    Set fDlg = Application.FileDialog(FileDialogType:=msoFileDialogFolderPicker)
    
    If fDlg.Show = -1 Then
        sArquivo = fDlg.SelectedItems(1) & ""
    Else
        MsgBox "Não foi selecionada nenhuma pasta"
        GoTo final
    End If
    
    sNome = wsAtiva.Cells(3, 3).Value

    ActiveWorkbook.SaveCopyAs Filename:=sArquivo & sNome & ".xlsm"
    SetAttr sArquivo & sNome & ".xlsm", vbHidden
    
    Workbooks.Open Filename:=sArquivo & wsAtiva.Cells(3, 3).Value & ".xlsm"
    Windows(sNome & ".xlsm").Activate
    
    For i = ActiveWorkbook.Worksheets.Count To 1 Step -1
        Check = MsgBox("Confirma a cópia da planilha:" & vbNewLine & ActiveWorkbook.Worksheets(i).Name, vbYesNo, "Cópia")
        If Check = vbNo Then
            ActiveWorkbook.Worksheets(i).Delete
        End If
    Next i
    ActiveWorkbook.SaveAs FileFormat:=xlOpenXMLWorkbook
    ActiveWorkbook.Close
    
    SetAttr sArquivo & sNome & ".xlsx", vbNormal
    SetAttr sArquivo & sNome & ".xlsm", vbNormal
    Kill sArquivo & sNome & ".xlsm"

    MsgBox "Planilha criada com sucesso!" & vbNewLine & _
        "Nome da planilha: " & sNome & ".xlsx" & vbNewLine & _
        "Local da planilha: " & sArquivo

final:
    
    Set wsAtiva = Nothing
    Set fDlg = Nothing
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    
End Sub

Qualquer coisa da o grito.
Abraço

Xi se a planilha original é diferente do exemplo a chance de dar M é grande ...

Bom dia!

Pessoal obrigado pelas dicas, mais não funcionou, esta dando erro em tempo de execução. Só mais uma dúvida seria possível utilizar o array para selecionar e copiar as planilhas que eu informar, depois cria uma nova pasta, colar as planilhas e salvar com o nome da célula em um diretório definido (ex: C:Clientes)

Encontrei o código abaixo, porém não estou conseguindo adaptar por causa do If que ele possui, só consegui criar o arquivos com as planilhas que eu informar, mais trava tudo.

Sub Salvar()

Dim WB As Worksheet
Dim W As Workbook

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Set WB = Sheets("Base")
'Set W = Workbooks("esboço")

WB.Select

If WB.Range("C3").Value = "SIM" Then

Sheets(Array("SIM1", "SIM2")).Select
Sheets(Array("SIM1", "SIM2")).Copy
Sheets("SIM1").Select
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Range("A1").Select
Sheets("SIM2").Select
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Range("A1").Select
Else
Sheets(Array("NAO1", "NAO2")).Select
Sheets(Array("NAO1", "NAO2")).Copy
Sheets("NAO1").Select
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Range("A1").Select
Sheets("NAO2").Select
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Range("A1").Select
End If

'Salva o arquivo

Application.Dialogs(xlDialogSaveAs).Show

ActiveWindow.Close

WB.Select

MsgBox "Ficheiro Criado com Sucessoo", vbOKOnly, "Ficheiro Criado"

Application.ScreenUpdating = True

W.Save

End Sub

Esse codigo tem um tempo que escrevi ele para alguem aqui no forum, poste seu arquivo exatamente como ele é que faço os ajustes necessarios.

Isso ja era pra ter sido solucionado se vc tivesse postado o arquivo correto.

Explique exatamente o que vc quer colocando na planilha o resultado esperado.

E se seu problema é so o if pode apagar essas linhas

If WB.Range("C3").Value = "SIM" Then

Else
Sheets(Array("NAO1", "NAO2")).Select
Sheets(Array("NAO1", "NAO2")).Copy
Sheets("NAO1").Select
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Range("A1").Select
Sheets("NAO2").Select
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Range("A1").Select
End If