Use all ifs in a Macro

LeonnM · Feb 18th 2021

Hello everyone,

First of all, sorry for any mistakes, im a beginner(started learning 2 weeks ago before joining the internship im currently in).

So, i have a VBA Macro in which i created a filter for each department in my company, and it works perfectly fine when i want a singular department... but i cant get it too automate all departments at once. My boss told me to create some another "while" but i cant get it to work as i did with the first one. The idea is, i need this code to use all departments at once, to open all the tabs with emails so i just have to confirm it, instead of doing each department at once.

Please let me know if i didnt give enough information... im kinda desperate lol.

Code

Sub verificação_preliminar()

    Dim departamento As String
    Dim mês As String
    Dim ano As String
    Dim emails As String
    Dim a As Integer
            
    departamento = Sheets("workflow").Range("B4")
    mês = Sheets("workflow").Range("B5")
    ano = Sheets("workflow").Range("B6")
    emails = Application.WorksheetFunction.VLookup(departamento, Sheets("Apoio").Range("A1:B20"), 2, False)
End Sub

Sub follow_up_teste()
 
    Sheets("Planilha Completa").Select
    Sheets("Planilha Completa").Copy
    ChDir "G:\Controles Internos\Controles Internos\24. Acompanhamento de Apontamentos"
    ActiveWorkbook.SaveAs Filename:="G:\Controles Internos\Controles Internos\24. Acompanhamento de Apontamentos" & "Follow up de " & mês & " de " & ano & " - " & departamento & " Department" & ".xlsm", _
        FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
    
    Dim i As Integer
       
    i = 2
        
    While Cells(i, 6) <> ""
    
    If Cells(i, 6) <> departamento Then
    Cells(i, 6).EntireRow.Delete
    i = i - 1
    End If
    i = i + 1
    Wend
    
    'J,K,P,Q,R,S
    
    Columns("P:S").EntireColumn.Delete
    Columns("J:K").EntireColumn.Delete
    
    Dim outlook As Object
    Dim outlookMail As Object
      
    Set outlook = CreateObject("Outlook.Application")
    Set outlookMail = outlook.CreateItem(0)

    With outlookMail
        .Attachments.Add "G:\Controles Internos\Controles Internos\24. Acompanhamento de Apontamentos" & "Follow up de " & mês & " de " & ano & " - " & departamento & " Department" & ".xlsm"
        .To = emails
        '.CC = "[email protected]"
        '.BCC = "[email protected]"
        .Subject = "Follow up de " & mês & " de " & ano & " - " & departamento & " Department"
        .Body = "A body"
        .Display
    End With
    MsgBox "Por favor conferir e enviar o Follow up de " & departamento & " Department"
    
    Dim a As Integer
    
    a = 3
    
    While Cells(a, 1) <> ""
    
    departamento = ThisWorkbook.Sheets("apoio").Cells(a, 1)

If departamento = "TODOS OS DEPARTAMENTOS" Then
'Comando
a = a + 1

Else

Call follow_up

End If

a = a - 1
        
Wend

End Sub

Display More

Mumps · Feb 18th 2021

It would be easier to help and test possible solutions if you could attach a copy of your file. Explain in detail what you want to do referring to specific cells, rows, columns and sheets using a few examples from your data (de-sensitized if necessary).

**Carim** · Feb 18th 2021

Hello,

As indicated by Mumps ... attaching a file ( without confidential data ) would help a lot ...

It would seem that you only need to insert a Loop of your various "departamentos" which are probably listed in the Column B of your worksheet named "workflow" ...

Hope this will help

**royUK** · Feb 18th 2021

I would have a ComboBox to select the departments from. Something like

Code

Sub verificação_preliminar()


Dim departamento As String
Dim mês As String
Dim ano As String
Dim emails As String
Dim a As Integer


departamento = Me.comnobox1.Value
mês = Sheets("workflow").Range("B5")
ano = Sheets("workflow").Range("B6")
emails = Application.WorksheetFunction.VLookup(departamento, Sheets("Apoio").Range("A1:B20"), 2, False)
End Sub

Display More

LeonnM · Feb 18th 2021

Hey guys, thank you so much already for the replies!! i've added the table in this reply, gonna explain a little bit more about what i need

In the "workflow" spreadsheet theres a combobox to pick the department(DEPARTAMENTO), and it works flawlessly going each by each, but i added an option called "todos os departamentos" which means "all departments" that could automatize everything so i wouldnt need to send department after department. the filter works by the column "A" in the "APOIO" spreadsheet.

what i need is the help to create the code or the code(lol) to do it, sort of like creating a loop going through every department and making it ready to send to the department's people.

thank you so much already and sorry for any grammar/english mistakes lol im learning a lot of things at the same time and trying to do my best!!

Mumps · Feb 18th 2021

Copy and paste this macro into the worksheet code module. Do the following: right click the tab name for your WORKFLOW sheet and click 'View Code'. Paste the macro into the empty code window that opens up. Close the code window to return to your sheet. First enter the data in B5 and B6 and then make a selection in B4. If you select TODOS OS DEPARTAMENTOS the emails for all departments will be created automatically. If you select only one department, the email for that department will be created automatically. You don't need any of the other macros and you don't need the Gerar FUP button.

Code

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.CountLarge > 1 Then Exit Sub
    If Target.Address(0, 0) <> "B4" Then Exit Sub
    Application.ScreenUpdating = False
    Dim departamento As String, mês As String, ano As String, emails As String, a As Long
    Dim v As Variant, i As Long, dept As Range, srcWS As Worksheet, outlook As Object, outlookMail As Object
    Set srcWS = Sheets("Apoio")
    mês = Range("B5")
    ano = Range("B6")
    If Target = "TODOS OS DEPARTAMENTOS" Then
        v = Application.Transpose(srcWS.Range("A3", srcWS.Range("A" & srcWS.Rows.Count).End(xlUp)).Value)
        For i = LBound(v) To UBound(v)
            Set dept = srcWS.Range("A:A").Find(v(i), LookIn:=xlValues, lookat:=xlWhole)
            If Not dept Is Nothing Then
                Sheets("Planilha Completa").Copy
                ChDir "G:\Controles Internos\Controles Internos\24. Acompanhamento de Apontamentos"
                ActiveWorkbook.SaveAs Filename:="G:\Controles Internos\Controles Internos\24. Acompanhamento de Apontamentos" & "Follow up de " & mês & " de " & ano & " - " & v(i) & " Department" & ".xlsm", _
                    FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
                With Sheets("Planilha Completa")
                    .Range("A1").CurrentRegion.AutoFilter 6, "<>" & v(i)
                    .AutoFilter.Range.Offset(1).EntireRow.Delete
                    .Range("A1").AutoFilter
                    .Columns("P:S").EntireColumn.Delete
                    .Columns("J:K").EntireColumn.Delete
                End With
                Set outlook = CreateObject("Outlook.Application")
                Set outlookMail = outlook.CreateItem(0)
                With outlookMail
                    .Attachments.Add "G:\Controles Internos\Controles Internos\24. Acompanhamento de Apontamentos" & "Follow up de " & mês & " de " & ano & " - " & departamento & " Department" & ".xlsm"
                    .To = dept.Offset(, 1)
                    '.CC = "[email protected]"
                    '.BCC = "[email protected]"
                    .Subject = "Follow up de " & mês & " de " & ano & " - " & departamento & " Department"
                    .Body = "A body"
                    .Display
                End With
                MsgBox "Por favor conferir e enviar o Follow up de " & departamento & " Department"
            End If
        Next i
    Else
        Set dept = srcWS.Range("A:A").Find(Target.Value, LookIn:=xlValues, lookat:=xlWhole)
        If Not dept Is Nothing Then
            Sheets("Planilha Completa").Copy
            ChDir "G:\Controles Internos\Controles Internos\24. Acompanhamento de Apontamentos"
            ActiveWorkbook.SaveAs Filename:="G:\Controles Internos\Controles Internos\24. Acompanhamento de Apontamentos" & "Follow up de " & mês & " de " & ano & " - " & departamento & " Department" & ".xlsm", _
                FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
            With Sheets("Planilha Completa")
                .Range("A1").CurrentRegion.AutoFilter 6, "<>" & Target.Value
                .AutoFilter.Range.Offset(1).EntireRow.Delete
                .Range("A1").AutoFilter
                .Columns("P:S").EntireColumn.Delete
                .Columns("J:K").EntireColumn.Delete
            End With
            Set outlook = CreateObject("Outlook.Application")
            Set outlookMail = outlook.CreateItem(0)
            With outlookMail
                .Attachments.Add "G:\Controles Internos\Controles Internos\24. Acompanhamento de Apontamentos" & "Follow up de " & mês & " de " & ano & " - " & Target.Value & " Department" & ".xlsm"
                .To = dept.Offset(, 1)
                '.CC = "[email protected]"
                '.BCC = "[email protected]"
                .Subject = "Follow up de " & mês & " de " & ano & " - " & departamento & " Department"
                .Body = "A body"
                .Display
            End With
            MsgBox "Por favor conferir e enviar o Follow up de " & departamento & " Department"
        End If
    End If
    Application.ScreenUpdating = True
End Sub

Display More

Mumps · Feb 18th 2021

My apologies. Please use this revised version:

Code

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.CountLarge > 1 Then Exit Sub
    If Target.Address(0, 0) <> "B4" Then Exit Sub
    Application.ScreenUpdating = False
    Dim departamento As String, mês As String, ano As String, emails As String, a As Long
    Dim v As Variant, i As Long, dept As Range, srcWS As Worksheet, outlook As Object, outlookMail As Object
    Set srcWS = Sheets("Apoio")
    mês = Range("B5")
    ano = Range("B6")
    If Target = "TODOS OS DEPARTAMENTOS" Then
        v = Application.Transpose(srcWS.Range("A3", srcWS.Range("A" & srcWS.Rows.Count).End(xlUp)).Value)
        For i = LBound(v) To UBound(v)
            Set dept = srcWS.Range("A:A").Find(v(i), LookIn:=xlValues, lookat:=xlWhole)
            If Not dept Is Nothing Then
                Sheets("Planilha Completa").Copy
                ChDir "G:\Controles Internos\Controles Internos\24. Acompanhamento de Apontamentos"
                ActiveWorkbook.SaveAs Filename:="G:\Controles Internos\Controles Internos\24. Acompanhamento de Apontamentos" & "Follow up de " & mês & " de " & ano & " - " & v(i) & " Department" & ".xlsm", _
                    FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
                With Sheets("Planilha Completa")
                    .Range("A1").CurrentRegion.AutoFilter 6, "<>" & v(i)
                    .AutoFilter.Range.Offset(1).EntireRow.Delete
                    .Range("A1").AutoFilter
                    .Columns("P:S").EntireColumn.Delete
                    .Columns("J:K").EntireColumn.Delete
                End With
                Set outlook = CreateObject("Outlook.Application")
                Set outlookMail = outlook.CreateItem(0)
                With outlookMail
                    .Attachments.Add "G:\Controles Internos\Controles Internos\24. Acompanhamento de Apontamentos" & "Follow up de " & mês & " de " & ano & " - " & v(i) & " Department" & ".xlsm"
                    .To = dept.Offset(, 1)
                    '.CC = "[email protected]"
                    '.BCC = "[email protected]"
                    .Subject = "Follow up de " & mês & " de " & ano & " - " & v(i) & " Department"
                    .Body = "A body"
                    .Display
                End With
                MsgBox "Por favor conferir e enviar o Follow up de " & v(i) & " Department"
            End If
        Next i
    Else
        Set dept = srcWS.Range("A:A").Find(Target.Value, LookIn:=xlValues, lookat:=xlWhole)
        If Not dept Is Nothing Then
            Sheets("Planilha Completa").Copy
            ChDir "G:\Controles Internos\Controles Internos\24. Acompanhamento de Apontamentos"
            ActiveWorkbook.SaveAs Filename:="G:\Controles Internos\Controles Internos\24. Acompanhamento de Apontamentos" & "Follow up de " & mês & " de " & ano & " - " & Target.Value & " Department" & ".xlsm", _
                FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
            With Sheets("Planilha Completa")
                .Range("A1").CurrentRegion.AutoFilter 6, "<>" & Target.Value
                .AutoFilter.Range.Offset(1).EntireRow.Delete
                .Range("A1").AutoFilter
                .Columns("P:S").EntireColumn.Delete
                .Columns("J:K").EntireColumn.Delete
            End With
            Set outlook = CreateObject("Outlook.Application")
            Set outlookMail = outlook.CreateItem(0)
            With outlookMail
                .Attachments.Add "G:\Controles Internos\Controles Internos\24. Acompanhamento de Apontamentos" & "Follow up de " & mês & " de " & ano & " - " & Target.Value & " Department" & ".xlsm"
                .To = dept.Offset(, 1)
                '.CC = "[email protected]"
                '.BCC = "[email protected]"
                .Subject = "Follow up de " & mês & " de " & ano & " - " & Target.Value & " Department"
                .Body = "A body"
                .Display
            End With
            MsgBox "Por favor conferir e enviar o Follow up de " & Target.Value & " Department"
        End If
    End If
    Application.ScreenUpdating = True
End Sub

Display More

LeonnM · Feb 18th 2021

Quote from Mumps

My apologies. Please use this revised version:

Code

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.CountLarge > 1 Then Exit Sub
    If Target.Address(0, 0) <> "B4" Then Exit Sub
    Application.ScreenUpdating = False
    Dim departamento As String, mês As String, ano As String, emails As String, a As Long
    Dim v As Variant, i As Long, dept As Range, srcWS As Worksheet, outlook As Object, outlookMail As Object
    Set srcWS = Sheets("Apoio")
    mês = Range("B5")
    ano = Range("B6")
    If Target = "TODOS OS DEPARTAMENTOS" Then
        v = Application.Transpose(srcWS.Range("A3", srcWS.Range("A" & srcWS.Rows.Count).End(xlUp)).Value)
        For i = LBound(v) To UBound(v)
            Set dept = srcWS.Range("A:A").Find(v(i), LookIn:=xlValues, lookat:=xlWhole)
            If Not dept Is Nothing Then
                Sheets("Planilha Completa").Copy
                ChDir "G:\Controles Internos\Controles Internos\24. Acompanhamento de Apontamentos"
                ActiveWorkbook.SaveAs Filename:="G:\Controles Internos\Controles Internos\24. Acompanhamento de Apontamentos" & "Follow up de " & mês & " de " & ano & " - " & v(i) & " Department" & ".xlsm", _
                    FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
                With Sheets("Planilha Completa")
                    .Range("A1").CurrentRegion.AutoFilter 6, "<>" & v(i)
                    .AutoFilter.Range.Offset(1).EntireRow.Delete
                    .Range("A1").AutoFilter
                    .Columns("P:S").EntireColumn.Delete
                    .Columns("J:K").EntireColumn.Delete
                End With
                Set outlook = CreateObject("Outlook.Application")
                Set outlookMail = outlook.CreateItem(0)
                With outlookMail
                    .Attachments.Add "G:\Controles Internos\Controles Internos\24. Acompanhamento de Apontamentos" & "Follow up de " & mês & " de " & ano & " - " & v(i) & " Department" & ".xlsm"
                    .To = dept.Offset(, 1)
                    '.CC = "[email protected]"
                    '.BCC = "[email protected]"
                    .Subject = "Follow up de " & mês & " de " & ano & " - " & v(i) & " Department"
                    .Body = "A body"
                    .Display
                End With
                MsgBox "Por favor conferir e enviar o Follow up de " & v(i) & " Department"
            End If
        Next i
    Else
        Set dept = srcWS.Range("A:A").Find(Target.Value, LookIn:=xlValues, lookat:=xlWhole)
        If Not dept Is Nothing Then
            Sheets("Planilha Completa").Copy
            ChDir "G:\Controles Internos\Controles Internos\24. Acompanhamento de Apontamentos"
            ActiveWorkbook.SaveAs Filename:="G:\Controles Internos\Controles Internos\24. Acompanhamento de Apontamentos" & "Follow up de " & mês & " de " & ano & " - " & Target.Value & " Department" & ".xlsm", _
                FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
            With Sheets("Planilha Completa")
                .Range("A1").CurrentRegion.AutoFilter 6, "<>" & Target.Value
                .AutoFilter.Range.Offset(1).EntireRow.Delete
                .Range("A1").AutoFilter
                .Columns("P:S").EntireColumn.Delete
                .Columns("J:K").EntireColumn.Delete
            End With
            Set outlook = CreateObject("Outlook.Application")
            Set outlookMail = outlook.CreateItem(0)
            With outlookMail
                .Attachments.Add "G:\Controles Internos\Controles Internos\24. Acompanhamento de Apontamentos" & "Follow up de " & mês & " de " & ano & " - " & Target.Value & " Department" & ".xlsm"
                .To = dept.Offset(, 1)
                '.CC = "[email protected]"
                '.BCC = "[email protected]"
                .Subject = "Follow up de " & mês & " de " & ano & " - " & Target.Value & " Department"
                .Body = "A body"
                .Display
            End With
            MsgBox "Por favor conferir e enviar o Follow up de " & Target.Value & " Department"
        End If
    End If
    Application.ScreenUpdating = True
End Sub

Display More

Heyyy man, thank you so much already!! i have a few questions, if i may?

First of all, the code works but it only captures the first department (account & taxation) correctly, all the other worksheets it creates has distorted columns(by that i mean the wrong columns deleted/left there) and blank data... you know what happened?

thank you so much!!!!

Mumps · Feb 18th 2021

In the sample file you posted, the Planilha Completa sheet had no data so it was hard to test the macro. Can you post a copy of your file that has some data in that sheet to make testing easier?

LeonnM · Feb 18th 2021

Quote from Mumps

In the sample file you posted, the Planilha Completa sheet had no data so it was hard to test the macro. Can you post a copy of your file that has some data in that sheet to make testing easier?

Hey, i created some data by hand just to make it easier

again, thank you so much!!!

Mumps · Feb 18th 2021

Try:

Code

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.CountLarge > 1 Then Exit Sub
    If Target.Address(0, 0) <> "B4" Then Exit Sub
    Application.ScreenUpdating = False
    Dim departamento As String, mês As String, ano As String, emails As String, a As Long
    Dim v As Variant, i As Long, dept As Range, srcWS As Worksheet, outlook As Object, outlookMail As Object
    Set srcWS = Sheets("Apoio")
    mês = Range("B5")
    ano = Range("B6")
    If Target = "TODOS OS DEPARTAMENTOS" Then
        v = Application.Transpose(srcWS.Range("A3", srcWS.Range("A" & srcWS.Rows.Count).End(xlUp)).Value)
        For i = LBound(v) To UBound(v)
            Set dept = srcWS.Range("A:A").Find(v(i), LookIn:=xlValues, lookat:=xlWhole)
            If Not dept Is Nothing Then
                If WorksheetFunction.CountIf(Sheets("Planilha Completa").Range("F:F"), v(i)) > 0 Then
                    Sheets("Planilha Completa").Copy
                    ChDir "G:\Controles Internos\Controles Internos\24. Acompanhamento de Apontamentos"
                    ActiveWorkbook.SaveAs Filename:="G:\Controles Internos\Controles Internos\24. Acompanhamento de Apontamentos" & "Follow up de " & mês & " de " & ano & " - " & v(i) & " Department" & ".xlsm", _
                        FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
                    With Sheets("Planilha Completa")
                        .Range("A1").CurrentRegion.AutoFilter 6, "<>" & v(i)
                        .AutoFilter.Range.Offset(1).EntireRow.Delete
                        .Range("A1").AutoFilter
                        .Columns("P:S").EntireColumn.Delete
                        .Columns("J:K").EntireColumn.Delete
                    End With
                    Set outlook = CreateObject("Outlook.Application")
                    Set outlookMail = outlook.CreateItem(0)
                    With outlookMail
                        .Attachments.Add "G:\Controles Internos\Controles Internos\24. Acompanhamento de Apontamentos" & "Follow up de " & mês & " de " & ano & " - " & v(i) & " Department" & ".xlsm"
                        .To = dept.Offset(, 1)
                        '.CC = "[email protected]"
                        '.BCC = "[email protected]"
                        .Subject = "Follow up de " & mês & " de " & ano & " - " & v(i) & " Department"
                        .Body = "A body"
                        .Display
                    End With
                    MsgBox "Por favor conferir e enviar o Follow up de " & v(i) & " Department"
                End If
            End If
        Next i
    Else
        Set dept = srcWS.Range("A:A").Find(Target.Value, LookIn:=xlValues, lookat:=xlWhole)
        If Not dept Is Nothing Then
            If WorksheetFunction.CountIf(Sheets("Planilha Completa").Range("F:F"), Target.Value) > 0 Then
                Sheets("Planilha Completa").Copy
                ChDir "G:\Controles Internos\Controles Internos\24. Acompanhamento de Apontamentos"
                ActiveWorkbook.SaveAs Filename:="G:\Controles Internos\Controles Internos\24. Acompanhamento de Apontamentos" & "Follow up de " & mês & " de " & ano & " - " & Target.Value & " Department" & ".xlsm", _
                    FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
                With Sheets("Planilha Completa")
                    .Range("A1").CurrentRegion.AutoFilter 6, "<>" & Target.Value
                    .AutoFilter.Range.Offset(1).EntireRow.Delete
                    .Range("A1").AutoFilter
                    .Columns("P:S").EntireColumn.Delete
                    .Columns("J:K").EntireColumn.Delete
                End With
                Set outlook = CreateObject("Outlook.Application")
                Set outlookMail = outlook.CreateItem(0)
                With outlookMail
                    .Attachments.Add "G:\Controles Internos\Controles Internos\24. Acompanhamento de Apontamentos" & "Follow up de " & mês & " de " & ano & " - " & Target.Value & " Department" & ".xlsm"
                    .To = dept.Offset(, 1)
                    '.CC = "[email protected]"
                    '.BCC = "[email protected]"
                    .Subject = "Follow up de " & mês & " de " & ano & " - " & Target.Value & " Department"
                    .Body = "A body"
                    .Display
                End With
                MsgBox "Por favor conferir e enviar o Follow up de " & Target.Value & " Department"
            End If
        End If
    End If
    Application.ScreenUpdating = True
End Sub

Display More

LeonnM · Feb 18th 2021

Quote from Mumps

Try:

Code

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.CountLarge > 1 Then Exit Sub
    If Target.Address(0, 0) <> "B4" Then Exit Sub
    Application.ScreenUpdating = False
    Dim departamento As String, mês As String, ano As String, emails As String, a As Long
    Dim v As Variant, i As Long, dept As Range, srcWS As Worksheet, outlook As Object, outlookMail As Object
    Set srcWS = Sheets("Apoio")
    mês = Range("B5")
    ano = Range("B6")
    If Target = "TODOS OS DEPARTAMENTOS" Then
        v = Application.Transpose(srcWS.Range("A3", srcWS.Range("A" & srcWS.Rows.Count).End(xlUp)).Value)
        For i = LBound(v) To UBound(v)
            Set dept = srcWS.Range("A:A").Find(v(i), LookIn:=xlValues, lookat:=xlWhole)
            If Not dept Is Nothing Then
                If WorksheetFunction.CountIf(Sheets("Planilha Completa").Range("F:F"), v(i)) > 0 Then
                    Sheets("Planilha Completa").Copy
                    ChDir "G:\Controles Internos\Controles Internos\24. Acompanhamento de Apontamentos"
                    ActiveWorkbook.SaveAs Filename:="G:\Controles Internos\Controles Internos\24. Acompanhamento de Apontamentos" & "Follow up de " & mês & " de " & ano & " - " & v(i) & " Department" & ".xlsm", _
                        FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
                    With Sheets("Planilha Completa")
                        .Range("A1").CurrentRegion.AutoFilter 6, "<>" & v(i)
                        .AutoFilter.Range.Offset(1).EntireRow.Delete
                        .Range("A1").AutoFilter
                        .Columns("P:S").EntireColumn.Delete
                        .Columns("J:K").EntireColumn.Delete
                    End With
                    Set outlook = CreateObject("Outlook.Application")
                    Set outlookMail = outlook.CreateItem(0)
                    With outlookMail
                        .Attachments.Add "G:\Controles Internos\Controles Internos\24. Acompanhamento de Apontamentos" & "Follow up de " & mês & " de " & ano & " - " & v(i) & " Department" & ".xlsm"
                        .To = dept.Offset(, 1)
                        '.CC = "[email protected]"
                        '.BCC = "[email protected]"
                        .Subject = "Follow up de " & mês & " de " & ano & " - " & v(i) & " Department"
                        .Body = "A body"
                        .Display
                    End With
                    MsgBox "Por favor conferir e enviar o Follow up de " & v(i) & " Department"
                End If
            End If
        Next i
    Else
        Set dept = srcWS.Range("A:A").Find(Target.Value, LookIn:=xlValues, lookat:=xlWhole)
        If Not dept Is Nothing Then
            If WorksheetFunction.CountIf(Sheets("Planilha Completa").Range("F:F"), Target.Value) > 0 Then
                Sheets("Planilha Completa").Copy
                ChDir "G:\Controles Internos\Controles Internos\24. Acompanhamento de Apontamentos"
                ActiveWorkbook.SaveAs Filename:="G:\Controles Internos\Controles Internos\24. Acompanhamento de Apontamentos" & "Follow up de " & mês & " de " & ano & " - " & Target.Value & " Department" & ".xlsm", _
                    FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
                With Sheets("Planilha Completa")
                    .Range("A1").CurrentRegion.AutoFilter 6, "<>" & Target.Value
                    .AutoFilter.Range.Offset(1).EntireRow.Delete
                    .Range("A1").AutoFilter
                    .Columns("P:S").EntireColumn.Delete
                    .Columns("J:K").EntireColumn.Delete
                End With
                Set outlook = CreateObject("Outlook.Application")
                Set outlookMail = outlook.CreateItem(0)
                With outlookMail
                    .Attachments.Add "G:\Controles Internos\Controles Internos\24. Acompanhamento de Apontamentos" & "Follow up de " & mês & " de " & ano & " - " & Target.Value & " Department" & ".xlsm"
                    .To = dept.Offset(, 1)
                    '.CC = "[email protected]"
                    '.BCC = "[email protected]"
                    .Subject = "Follow up de " & mês & " de " & ano & " - " & Target.Value & " Department"
                    .Body = "A body"
                    .Display
                End With
                MsgBox "Por favor conferir e enviar o Follow up de " & Target.Value & " Department"
            End If
        End If
    End If
    Application.ScreenUpdating = True
End Sub

Display More

Hey...

Now it worked with the first one, as it did before (accounting & taxation), but the rest of the departments dont even start

Mumps · Feb 19th 2021

I tested the macro and it works properly. The macro first checks if a department exists in column F of sheet Planilha Completa. If a particular department does not exist, then then macro doesn't create a new workbook or email. I assumed that this is the way you want it to work. Did I assume correctly? Also, you have to make sure that the department names in column F of sheet Planilha Completa are exactly the same as those in column A of the Apoio sheet.

Use all ifs in a Macro

Participate now!

Share

Tags