Macro to amend section of Code

H

howard

Well-known Member
Joined
Jun 26, 2006
Messages
6,589
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
 
Sort by date Sort by votes
Hi,
you have not deleted that part of your existing code

Try this update

VBA Code: 
 Sub Email_Sheets()
    ' Check if G2:G20 is blank
    Dim rng            As Range, FilteredRange As Range
    Dim strFile        As String, strBody As String, strName As String
    Dim ws             As Worksheet
    Dim wsArr         As Variant
    Dim lr                As Long
   
    Set ws = ThisWorkbook.Worksheets("Macro")
   
    Set rng = ws.Range("G2:G20")
   
    If WorksheetFunction.CountBlank(rng) = rng.Cells.Count Then
   
        Exit Sub
       
    Else
       
        With Application
            .ScreenUpdating = False: .DisplayAlerts = False
        End With
       
        On Error Resume Next
        Set FilteredRange = ws.Range("J2:J" & ws.Cells(ws.Rows.Count, "J").End(xlUp).Row).SpecialCells(xlCellTypeVisible)
        On Error GoTo myerror
       
        If Not FilteredRange Is Nothing Then
            If FilteredRange.Cells.Count = 1 Then strName = FilteredRange.Cells(1).Value
        End If
       
        strBody = EmailMessage(strName)
       
        strFile = ThisWorkbook.Path & "\" & "Sales Variances.xlsx"
       
        With ws
            lr = .Range("S:S").Find("", , xlValues, , , xlNext, , , False).Row - 1
            wsArr = Application.Transpose(.Range("S2:S" & lr))
        End With
       
        Worksheets(wsArr).Copy
       
        With ActiveWorkbook
            .SaveAs Filename:=strFile, FileFormat:=51
            .Close savechanges:=False
        End With
       
        With CreateObject("Outlook.Application").CreateItem(0)
            .Display
            .To = Join(Application.Transpose(ws.Range("I2:I15").SpecialCells(xlCellTypeVisible).Value), ";")
            .Subject = "Variance Report"
            .Body = strBody
            .Attachments.Add strFile
        End With
        Kill strFile
       
    End If
   
myerror:
    With Application
        .ScreenUpdating = True: .DisplayAlerts = True
    End With
   
    If Err <> 0 Then MsgBox (Error(Err)), 48, "Error"
End Sub

You will need to ensure the FUNCTION I posted is placed in a STANDARD module.

Dave
 
Last edited:
Upvote 0

Excel Facts

Format cells as currency
Select range and press Ctrl+Shift+4 to format cells as currency. (Shift 4 is the $ sign).
howard said:
Thanks

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
Click to expand...
It should be done with: If filteredRange.Cells.Count > 1 Then
Try:
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 = filteredRange.Cells(1).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 Dave,. We are getting closer to a solution. Where I have formulas in Col J2 onwards and these return a blank and there is one item in say J5 that contians Fran and I run the macro I get Subscript out of range


The message should say Hi Fran
The Formulas in Col J are

Code: 
 =IFERROR(IF(ISNUMBER(SEARCH("Francine", I2)), "Fran", PROPER(LEFT(I2, FIND(".", I2) - 1))), "")
 
Upvote 0
howard said:
I run the macro I get Subscript out of range
Click to expand...

Can you step through the code and let me know which line errors

I am about to leave the house so may be awhile before I can respond

Dave
 
Upvote 0
Hai Dave

I get subscript out of range when it reaches this part of the code

Code: 
If Err <> 0 Then MsgBox (Error(Err)), 48, "Error"

No urgent rush. I'm also going out in nexxt 15 mins
 
Upvote 0
Hi Howard
than line is just reporting the error but no worries

I am not able to fully test but as a guess, try adding line of code shown in bold & see if resolves

Rich (BB code): 
On Error Resume Next
        Set FilteredRange = ws.Range("J2:J" & ws.Cells(ws.Rows.Count, "J").End(xlUp).Row).SpecialCells(xlCellTypeVisible)
        If Err <> 0 Then Err.Clear
        On Error GoTo myerror

If still and issue, suggest place copy of your workbook with dummy data on a file sharing site like dropbox

Dave
 
Upvote 0
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

Rich (BB code): 
 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
 
Upvote 0
Hi @howard

I changed the approach from considering the filtered rows, try the following macro.
It's tested with the file you shared.

VBA Code: 
Sub Email_Sheets_v1()
  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()
  Dim lr As Long, n As Long, i As Long
 
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
 
  Set ws = Sheets("Macro")
  lr = ws.Cells(ws.Rows.Count, "J").End(xlUp).Row
   
  For i = 2 To lr
    If ws.Range("J" & i).EntireRow.Hidden = False And ws.Range("J" & i).Value <> "" And _
       ws.Range("I" & i).Value <> "" And ws.Range("S" & i).Value <> "" Then
      sName = ws.Range("J" & i).Value
      strTo = strTo & ws.Range("I" & i).Value & ";"
      ReDim Preserve wsArr(n)
      wsArr(n) = ws.Range("S" & i).Value
      n = n + 1
    End If
  Next
   
  If n > 1 Then sName = "Guys"
  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"
  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

--------------
I hope to hear from you soon.
Respectfully
Dante Amor
--------------​
 
Upvote 0
Solution
You must log in or register to reply here.

Similar threads

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

Forum statistics

Threads
1,223,227
Messages
6,170,848
Members
452,361
Latest member
d3ad3y3

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