Excel VBA salvar planilha nome variavel

[Quedison Nunes Alves]

Bom dia Pessoal
Tenho uma solicitação próximo deste assunto.

Preciso Salvar uma copia da planilha atual .

mas preciso que seja verificado se ja existe um arquivo com o mesmo nome .
Ex. "Relatorio-01-08-2022- 01"
Se já existe quero que seja salvo para "Relatorio-01-08-2022- 02"

Após salvar a copia preciso que seja enviado via e-mail em anexo.

Poderia me ajudar, acredito que tenha que adicionar uma estrutura de repeticao.

Tenho o seguinte condigo.

 

 

Sub SavaCopia_envia_Email()


    Dim sPara      As String
    Dim sMsg       As String
    Dim sAssunt    As String
    Dim NomeCopia As String
    Dim DirCopia    As String
    Dim Contador   As Integer
    Dim Caminho     As String
    
    

        NomeCopia = "Relatório_" & VBA.Format(VBA.Now, "dd-mm-yyyy") & "." & Contador & ".xlsx"
        Caminho = "C:\Users\Nunes\Desktop\PROJETO\Teste\BKPDOCUMENTO\"
        DirCopia = "C:\Users\Nunes\Desktop\PROJETO\Teste\BKPDOCUMENTO\" + NomeCopia
        Contador = 1
    
        
        If NomeCopia = Caminho Then
        Contador = Contador + 1
        
        Else
        
        ActiveWorkbook.SaveAs Filename:= _
        Caminho + NomeCopia, _
        FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
        ReadOnlyRecommended:=False, CreateBackup:=False
        
        
        End If
        
    
        'Enviar e-mail
    
        NomeCopia = "Relatório_" & VBA.Format(VBA.Now, "dd-mm-yyyy") & "." & Contador & ".xlsx"
        sAssunt = "Assunto de Envio de Relatório em Anexo"
        sMsg = "Mensagem teste de envio de e-mail com anexo"
  
        Dim OutlookApp   As Object
        Dim OutlookMail  As Object
        Set OutlookApp = CreateObject("Outlook.Application")
        Set OutlookMail = OutlookApp.CreateItem(0)
    
         With OutlookMail
        .to = ""
        .CC = ""
        .BCC = ""
        .Subject = sAssunt
        .Body = sMsg
        .Attachments.Add DirCopia
        .Display ' para envia o email diretamente defina o código  .Send
        
        End With
        Set OutlookMail = Nothing
        Set OutlookApp = Nothing
        
        
    
End Sub

 

[AfonsoMira]

Boas @Quedison Nunes Alves ,

Experimente assim:
 

Sub SavaCopia_envia_Email()

    Dim contador As Integer
    Dim caminho As String: caminho = "C:\Users\Nunes\Desktop\PROJETO\Teste\BKPDOCUMENTO\"
    Dim nomeCopia As String: nomeCopia = "Relatório_" & VBA.Format(VBA.Now, "dd-mm-yyyy") & "." & contador & ".xlsx"
    Dim dirCopia As String: dirCopia = caminho & nomeCopia
    Dim verifica_existe As String

    verifica_existe = Dir(dirCopia)

    Do While verifica_existe <> ""
        contador = contador + 1
        nomeCopia = "Relatório_" & VBA.Format(VBA.Now, "dd-mm-yyyy") & "." & contador & ".xlsx"
        dirCopia = caminho & nomeCopia
        verifica_existe = Dir(dirCopia)
    Loop

    ThisWorkbook.SaveAs Filename:= _
                        caminho + nomeCopia, _
                        FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
                        ReadOnlyRecommended:=False, CreateBackup:=False

    Dim sPara      As String
    Dim sMsg       As String
    Dim sAssunt    As String

    'Enviar e-mail
    nomeCopia = "Relatório_" & VBA.Format(VBA.Now, "dd-mm-yyyy") & "." & contador & ".xlsx"
    sAssunt = "Assunto de Envio de Relatório em Anexo"
    sMsg = "Mensagem teste de envio de e-mail com anexo"

    Dim OutlookApp   As Object
    Dim OutlookMail  As Object
    Set OutlookApp = CreateObject("Outlook.Application")
    Set OutlookMail = OutlookApp.CreateItem(0)

    With OutlookMail
        .to = ""
        .CC = ""
        .BCC = ""
        .Subject = sAssunt
        .Body = sMsg
        .Attachments.Add dirCopia
        .Display                                 ' para envia o email diretamente defina o código  .Send
    End With

    Set OutlookMail = Nothing
    Set OutlookApp = Nothing

End Sub

 

[Quedison Nunes Alves]

@AfonsoMira Deu certo, Me ajudou bastante

Obrigado..