Yuri Watzech

Boa tarde a todos!

 

Estou com uma dúvida em uma programação VBA. Falta alguns trechos para finalizar o programa, mas eu nao estou conseguindo fazer =/ Alguém poderia me ajudar, por favor?

Vamos lá!

A lógica que o programa tem que seguir é a seguinte:

 

Selecionar Célula A2
Selecionar Coluna A até o dado da coluna An <diferente> An + 1
Selecionar todos os dados a partir da coluna D até Dn
Copiar estes dados
Abrir uma nova planilha no formato CSV
Colar na célula A2 da nova planilha
Selecionar todos os dados a partir da coluna E até En
Colar na célula B2 da nova planilha
Selecionar todos os dados a partir da coluna F até Fn
Colar na célula C2 da nova planilha
Selecionar todos os dados a partir da coluna G até Hn
Colar na célula D2 da nova planilha
Selecionar todos os dados a partir da coluna H até In
Colar na célula E2 da nova planilha
Selecionar todos os dados a partir da coluna I até Jn
Colar na célula F2 da nova planilha
Selecionar todos os dados a partir da coluna J até Kn
Colar na célula G2 da nova planilha
Copiar o dado da célula An
Salvar a Planilha Nova como nome da célula An copiada
Fechar a Planilha Nova.
(loop) Repetir o processo a partir da célula An + 1, e assim por diante (A cada dado diferente da coluna A criar uma nova planilha), até a ultima linha

 

A planillha que fiz, está fazendo o processo de copiar e colar perfeitamente, porém não sei fazer a macro reconhecer a mudança de conteúdo das células (An <> An + 1), assim criando apenas uma planilha copia contendo tudo.

 

Segue planilha em anexo com a VBA e a planilha(vazia) que usei de base para criação.

 

Código:

 

Sub Macro()
    Workbooks.Open ("C:\Users\yuri.watzech\Desktop\Macro Cut-Over Pedido\Saving CSV Test\Planilha Padrão.xlsx")
    Worksheets("Plan1").Activate
    Windows("Macro V2.xlsm").Activate
    Range("D2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Windows("Planilha Padrão.xlsx").Activate
    Range("A2").Select
    ActiveSheet.Paste
    Windows("Macro V2.xlsm").Activate
    Range("E2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Application.CutCopyMode = False
    Selection.Copy
    Windows("Planilha Padrão.xlsx").Activate
    Range("B2").Select
    ActiveSheet.Paste
    Windows("Macro V2.xlsm").Activate
    Range("F2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Application.CutCopyMode = False
    Selection.Copy
    Windows("Planilha Padrão.xlsx").Activate
    Range("C2").Select
    ActiveSheet.Paste
    Windows("Macro V2.xlsm").Activate
    Range("G2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Application.CutCopyMode = False
    Selection.Copy
    Windows("Planilha Padrão.xlsx").Activate
    Range("D2").Select
    ActiveSheet.Paste
    Windows("Macro V2.xlsm").Activate
    Range("H2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Application.CutCopyMode = False
    Selection.Copy
    Windows("Planilha Padrão.xlsx").Activate
    Range("E2").Select
    ActiveSheet.Paste
    Windows("Macro V2.xlsm").Activate
    Range("I2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Application.CutCopyMode = False
    Selection.Copy
    Windows("Planilha Padrão.xlsx").Activate
    Range("F2").Select
    ActiveSheet.Paste
    Windows("Macro V2.xlsm").Activate
    Range("J2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Application.CutCopyMode = False
    Selection.Copy
    Windows("Planilha Padrão.xlsx").Activate
    Range("G2").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    ActiveWorkbook.SaveAs Filename:= _
        "C:\Users\yuri.watzech\Desktop\Macro Cut-Over Pedido\Saving CSV Test\" & Cells(ActiveCell.Row, 1) & ".xlsx" _
        , FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    ActiveWindow.Close
End Sub
 

 

Obrigado desde já!!!

 

Macro V2.xlsx

Planilha Padrão.xlsx

Tentei tudo isso ai =/

 

Infelizmente não deu haha 

 

No idea kkk  tks bro! @olliver.soul

@olliver.soul tentei aqui substituir o código, continuou mandando apenas para o primeiro destinatário.......
O código ficou assim:

'Email automático em massa para fornecedores - Autor: Yuri Watzech'

Sub Enviar_Email()
    Dim OutlookApp As Object
    Dim OutlookMail As Object
    Set OutlookApp = CreateObject("Outlook.Application")
    Set OutlookMail = OutlookApp.CreateItem(0)
    
    On Error Resume Next
    
     For i = 3 To 6
     
        If Exemplo1.Range("F" & i).Value <> "Ok" Then
             With OutlookMail
                .To = Exemplo1.Range("F" & i).Value
                .CC = Exemplo1.Range("G" & i).Value
                .BCC = Exemplo1.Range("H" & i).Value
                .Subject = Exemplo1.Range("E" & i).Value
                .HTMLBody = Exemplo1.Range("L" & i).Value
                .Send
                '.Display 'Use .Send para enviar o email direto sem exibir na tela''
                
             End With
        End If
    Next i
    
    On Error GoTo 0
    Set OutlookMail = Nothing
    Set OutlookApp = Nothing
End Sub
 

 

=/

Bom dia a todos!
 

Gostaria de tirar uma dúvida e entender o que estou fazendo de errado no meu código.
Estou criando uma Macro para enviar emails em massa para destinatários diferentes, cada um com um texto.

Meu problema esta sendo que ele esta enviando somente para a primeira linha da planilha, não está repetindo para os demais.

Imagino que seja um Loop faltante, mas pelo fato de ter um "Next i", entendo que funcionaria....

 

Alguém pode me ajudar? Obrigado!!!

 

Obs: São 4 Emails diferentes (4 Linhas)

Código:

 

Sub Enviar_Email()
    Dim OutlookApp As Object
    Dim OutlookMail As Object
    Set OutlookApp = CreateObject("Outlook.Application")
    Set OutlookMail = OutlookApp.CreateItem(0)
    
    On Error Resume Next
    
     For i = 1 To 4
     
        If Exemplo1.Range("F" & i + 2).Value <> "Ok" Then
             With OutlookMail
                .To = Exemplo1.Range("F" & i + 2).Value
                .CC = Exemplo1.Range("G" & i + 2).Value
                .BCC = Exemplo1.Range("H" & i + 2).Value
                .Subject = Exemplo1.Range("E" & i + 2).Value
                .HTMLBody = Exemplo1.Range("L" & i + 2).Value
                .Send
                '.Display 'Use .Send para enviar o email direto sem exibir na tela''
                
             End With
        End If
    Next i
    
    On Error GoTo 0
    Set OutlookMail = Nothing
    Set OutlookApp = Nothing
End Sub
 

 

 

Segue print da planilha:

 

Obrigado desde já!!! =)