Macro to amend section of Code

H

howard

Well-known Member
Joined
Jun 26, 2006
Messages
6,595
Office Version
  1. 2021
Platform
  1. Windows
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
Code: 
 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
 

Excel Facts

How can you turn a range sideways?
Copy the range. Select a blank cell. Right-click, Paste Special, then choose Transpose.
Sort by date Sort by votes
Hi @howard , I hope you are well.

This is the amended macro.

There were some details in your macro that I couldn't pass up, so I went through the entire macro to test and amend it.
VBA Code: 
Sub Email_Sheets()
  Dim ws As Worksheet
  Dim sFile As String, strBody As String, sName As String, strTo As String
  Dim filteredRange As Range, rng As Range
  Dim wsArr As Variant
  Dim lr As Long, n As Long
  
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  
  Set ws = Sheets("Macro")
  lr = ws.Cells(ws.Rows.Count, "J").End(xlUp).Row
  Set rng = ws.Range("G2:G" & lr)
  If WorksheetFunction.CountBlank(rng) = rng.Cells.Count Then
    Exit Sub
  End If
    
  On Error Resume Next
  Set filteredRange = ws.Range("J2:J" & lr).SpecialCells(xlCellTypeVisible)
  n = filteredRange.Rows.Count
  On Error GoTo 0

  If n = 1 Then
    sName = ws.UsedRange.Offset(1, 9).SpecialCells(xlCellTypeVisible).Cells(1).Value
    strTo = ws.UsedRange.Offset(1, 8).SpecialCells(xlCellTypeVisible).Cells(1).Value
  Else
    sName = "Guys"
    strTo = Join(Application.Transpose(ws.Range("I2:I" & lr).SpecialCells(xlCellTypeVisible)), ";")
  End If
  strBody = "Hi " & sName & 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"

  sFile = ThisWorkbook.Path & "\" & "Sales Variances.xlsx"
  wsArr = Application.Transpose(ws.Range("S2:S" & lr).SpecialCells(xlCellTypeVisible))
  Sheets(wsArr).Copy

  With ActiveWorkbook
    .SaveAs Filename:=sFile, FileFormat:=51
    .Close savechanges:=False
  End With
  With CreateObject("Outlook.Application").CreateItem(0)
    .Display
    .to = strTo
    .Subject = "Variance Report"
    .Body = strBody
    .Attachments.Add sFile
  End With
  Kill sFile
  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
End Sub

Note: Do not use reserved words for your variables, such as File, Name, you could have conflicts.

--------------
Let me know the result and I'll get back to you as soon as I can.
Cordially
Dante Amor
--------------​
 
Upvote 0
Hi Dsante

Thanks for the hrelp. Where only one item in Col j from row 2 onwards message still stating Hi Guys....


I have attached some sample data . There are formulas in Col J and result in a Blank if criteria not met. My sample data has no formulas

See link below

www.dropbox.com

Data Sample.xlsx

Shared with Dropbox
www.dropbox.com www.dropbox.com


Kindly amend code
 
Upvote 0
This is untested:
VBA Code: 
        If Not filteredRange Is Nothing Then
            If filteredRange.Cells.Count > 1 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
        End If
 
Upvote 0
Thanks for the help Akuini

Where there is only one item in Col J from row 2 onwards message still starts with Hi Guys instead of Hi and combing the item in Col J for eg Hi James

Where there are blanks from J2 to J3 and only data in J4, I get a run time error : Subscript out of range and code below is highlighted

Code: 
 Sheets(wsArr).Copy
 
Upvote 0
Hi,
not fully tested but another idea maybe

Rich (BB code): 
 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

       Dim strName As String
        If Not filteredRange Is Nothing Then
            If filteredRange.Cells.Count = 1 Then strName = ws.Range("J2").SpecialCells(xlCellTypeVisible).Value
        End If
        strBody = EmailMessage(strName)

      ' rest of code
End Sub

Place this code in STANDARD module

VBA Code: 
Function EmailMessage(ByVal UsersName As String) As String
   If Len(UsersName) = 0 Then UsersName = "Guys"
    EmailMessage = "Hi " & UsersName & 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 Function

Dave
 
Upvote 0
howard said:
Where there is only one item in Col J from row 2 onwards message still starts with Hi Guys instead of Hi and combing the item in Col J for eg Hi James
Click to expand...

Try change this:
VBA Code: 
name = ws.Range("J2").SpecialCells(xlCellTypeVisible).Value
to this:
VBA Code: 
name = filteredRange.Cells(1).Value
 
Upvote 0
Thanks Dave. Where I have one item in Col J, The mesage says Hi and combines names in Col j eg Hi James which is correct

Where I have several items in Col J, It still says Hi James

There could be blanks between the row eg J2 has data, J3 is blank, J4,:J5 has data , J6 is blank and J7 has Data

Kindly amend your code

See my full code

Code: 
 Function EmailMessage(ByVal UsersName As String) As String
   If Len(UsersName) = 0 Then UsersName = "Guys"
    EmailMessage = "Hi " & UsersName & 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 Function
 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

        Dim strName As String
        If Not filteredRange Is Nothing Then
            If filteredRange.Cells.Count = 1 Then strName = ws.Range("J2").SpecialCells(xlCellTypeVisible).Value
        End If

        If Not filteredRange Is Nothing Then
            ' Only one visible item in Col J from row 2 onwards
            Dim name As String
            name = filteredRange.Cells(1).Value
            If name <> "" Then
                strBody = "Hi " & name & 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
                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"
            End If
        Else
            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"
        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


Kindly amend you code
 
Upvote 0
Akuini said:
Try change this:
VBA Code: 
name = ws.Range("J2").SpecialCells(xlCellTypeVisible).Value
to this:
VBA Code: 
name = filteredRange.Cells(1).Value
Click to expand...
Thanks
Akuini said:
Try change this:
VBA Code: 
name = ws.Range("J2").SpecialCells(xlCellTypeVisible).Value
to this:
VBA Code: 
name = filteredRange.Cells(1).Value
Click to expand...
Thanks Akuini, No more run time error, but need Code to generste mesage Hi Guys where more than one non blank item in Col J from row 2 onwards, otherwise Hi and combine item in Col J eg. Hi James
 
Upvote 0
You must log in or register to reply here.

Similar threads

H
  • Question Question
Macro to email Report
Replies
2
Views
549
howard
H
H
  • Solved
Cannot supress Display alert Message
Replies
4
Views
559
howard
H
P
  • Question Question
putting a snippet of code from one to another somehow
Replies
5
Views
304
Patriot2879
P
D
  • Solved
VBA Function to Paste Table into Outlook Email Resulting in HTML language in Email
Replies
8
Views
570
smozgur
smozgur
N
  • Question Question
VBA Code - add emails to outlook BCC from list (that updates)
Replies
1
Views
376
NormChart55
N

Forum statistics

Threads
1,223,893
Messages
6,175,246
Members
452,623
Latest member
cliftonhandyman

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top