Macro to amend section of Code

[howard]

I have code below to email sheets based on certain criteria

I need the portion of the code amended containing the message in the body of the email

Where there is more than one item in Col J from row 2 onwards , the message to start off with Hi Guys ... , which is correct

However if there is only one visible item in Col J from row 2 onwards message must state Hi and item in Col J for eg Hi Mike....


I only need this portion amended in my code

Your assistance is most appreciated

 Sub Email_Sheets()
    ' Check if G2:G20 is blank
    Dim rng As Range
    Set rng = Sheets("Macro").Range("G2:G20")

    If WorksheetFunction.CountBlank(rng) = rng.Cells.Count Then
        Exit Sub
    Else
        Dim File As String, strBody As String, ws As Worksheet, wsArr, LR As Long
        Set ws = Sheets("Macro")

        Application.ScreenUpdating = False
        Application.DisplayAlerts = False

        Dim filteredRange As Range
        On Error Resume Next
        Set filteredRange = ws.Range("J2:J" & ws.Cells(ws.Rows.Count, "J").End(xlUp).Row).SpecialCells(xlCellTypeVisible)
        On Error GoTo 0

        If Not filteredRange Is Nothing Then
            ' More than one visible item in Col J from row 2 onwards
            strBody = "Hi Guys" & vbNewLine & vbNewLine & _
                      "Attached, please find Variance Reports pertaining to your branch" & vbNewLine & vbNewLine & _
                      "Please attend to the variances and advise once corrected" & vbNewLine & vbNewLine & _
                      "Regards" & vbNewLine & vbNewLine & _
                      "Howard"
        Else
            ' Only one visible item in Col J from row 2 onwards
            Dim name As String
            name = ws.Range("J2").SpecialCells(xlCellTypeVisible).Value
            If name <> "" Then
                strBody = "Hi " & name & vbNewLine & vbNewLine & _
                          "Attached, please find Reports pertaining to your branch" & vbNewLine & vbNewLine & _
                          "Please attend to the variances and advise once corrected" & vbNewLine & vbNewLine & _
                          "Regards" & vbNewLine & vbNewLine & _
                          "Howard"
            Else
                strBody = "Hi Guys" & vbNewLine & vbNewLine & _
                          "Attached, please find Reports pertaining to your branch" & vbNewLine & vbNewLine & _
                          "Please attend to the variances and advise once corrected" & vbNewLine & vbNewLine & _
                          "Regards" & vbNewLine & vbNewLine & _
                          "Howard"
            End If
        End If

        File = ThisWorkbook.Path & "\" & "Sales Variances.xlsx"
        With Sheets("Macro")
            LR = .Range("S:S").Find("", , xlValues, , , xlNext, , , False).Row - 1
            wsArr = Application.Transpose(.Range("S2:S" & LR))
        End With

        Sheets(wsArr).Copy

        With ActiveWorkbook
            .SaveAs Filename:=File, FileFormat:=51
            .Close savechanges:=False
        End With
        With CreateObject("Outlook.Application").CreateItem(0)
            .Display
            .To = Join(Application.Transpose(Sheets("Macro").Range("I2:I15").SpecialCells(xlCellTypeVisible).Value), ";")
            .Subject = "Variance Report"
            .Body = strBody
            .Attachments.Add File
        End With
        Kill File
        Application.ScreenUpdating = True
        Application.DisplayAlerts = True
    End If
End Sub

 

[howard]

Hi
As far as I can determine, solution provided is doing what you asked for in original question & should resolve that issue.
From the limited sample workbook provided - The Subscript Out Of Range Error is a new issue being a result of your array variable wsArr not being populated

The error trap I included in to your code is doing its job but to overcome this issue I suggest that you prepare a more complete workbook sample for the forum & post it as a new question

 With ws
            lr = .Range("S:S").Find("", , xlValues, , , xlNext, , , False).Row - 1
            wsArr = Application.Transpose(.Range("S2:S" & lr))
        End With
      
        Worksheets(wsArr).Copy

Dave

Hi Dave


many thanks for all your effort. Dante's solution works perfectly