Este fórum está sendo desativado

[kamada]

Pessoal é o seguinte...
Estou com dificuldades com o seguinte código...

Código: Selecionar todos

Sub CriarArquivo()
'
' CriarArquivo Macro
'

'
    Range("B1").Select
    ActiveCell.FormulaR1C1 = ActiveCell.Value + 1

    ActiveWorkbook.SaveAs Filename:= _
        "C:\Users\Artes\Desktop\teste\" & Mid(ActiveCell.Value, 7, 4) & "_" & Mid(ActiveCell.Value, 4, 2) & "_" & Mid(ActiveCell.Value, 1, 2) & ".xlsm", FileFormat:= _
        xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
End Sub

Podemos ver que é um código onde cria um novo arquivo e muda a data do mesmo, certo?
Só que ao invés de Criar um novo arquivo eu precisaria que ele criasse várias abas no mesmo arquivo, conseguem me compreender?
Vou anexar a planilha que eu estou utilizando.
Obrigado desde já.

[alexandrevba]

Boa tarde!!

Seria algo como isso?

Código: Selecionar todos

Sub AleVBA_3216()
    Dim i As Integer
    Dim ws As Worksheet
    Dim sh As Worksheet
    
    Set ws = Sheets("02")    'Considerando que há essa guia de nome "02"
    Set sh = Sheets("Nomes") 'Considerando que há essa guia de nome "Nomes"
    
    Application.ScreenUpdating = 0
    For i = 2 To Range("A" & Rows.Count).End(xlUp).Row
        Sheets("02").Copy After:=sh
        ActiveSheet.Name = sh.Range("A" & i).Value
    Next i
    Application.ScreenUpdating = 1
End Sub

Att

[kamada]

Então Alexandre, tentei utilizar esse código, porém deu um erro aqui.
Será que você não consegue altera-lo diretamente na planilha que eu anexei e anexa-la novamente?
Se sim, agradeço.
Grande abraço e obrigado.

[kamada]

Pra você entender melhor Alexandre, anexei a planilha pronta aqui.
Abra ela, em seguida abra o editor VBA e altere o local que o novo arquivo será salvo, e salve as alterações.
Depois vá na planilha e Pressione CTRL+R pra você ver o que acontece.

[alexandrevba]

Bom dia!!

Tente isso!

Código: Selecionar todos

Sub AleVBA_3216()
Dim sName As String
Dim i As Integer
Set ws = Sheets(Sheets.Count)
i = ActiveWorkbook.Worksheets.Count

sName = Mid([D1].Value, 7, 4) & "_" & Mid([D1].Value, 4, 2) & "_" & Mid([D1].Value, 1, 2) 'Application.InputBox("Digite o nome da guia", "Espelho")
If sName = "" Then Exit Sub
ws.Copy after:=Worksheets(i)
[D1].FormulaR1C1 = [D1].Value + 1
ActiveSheet.Name = sName

End Sub

Att