VBA to send sheets based on column values

catscantuseexcel

catscantuseexcel

New Member
Joined
Jul 24, 2023
Messages
2
Office Version
  1. 2019
Platform
  1. Windows
Hi,

I currently have vba to send multiple sheets in an excel as a new excel file as seen below. However, I am trying to add the following function:
- Instead of putting the sheet names in the vba (Test Sheet, Sheet Test), I would like the vba to take the name from the open sheet. So for example the sheet names I want to send to "dad are all listed in row 2 side by side in different colums. I would want it to loop through the row to find the sheet names which is then send via mail. Is this possible?


VBA Code: 
Sub Mail_Sheets_Array()
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim OutApp As Object
    Dim OutMail As Object
    Dim sh As Worksheet
    Dim TheActiveWindow As Window
    Dim TempWindow As Window

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    Set Sourcewb = ActiveWorkbook
    
    dad = Sheets("Send Mail").Cells(9, 2)
    mom = Sheets("Send Mail").Cells(20, 2)

    With Sourcewb
        Set TheActiveWindow = ActiveWindow
        Set TempWindow = .NewWindow
        .Sheets(Array("Test Sheet", "Sheet Test")).Copy
    End With

    TempWindow.Close

    Set Destwb = ActiveWorkbook

    With Destwb
        If Val(Application.Version) < 12 Then
            FileExtStr = ".xls": FileFormatNum = -4143
        Else
            Select Case Sourcewb.FileFormat
            Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
            Case 52:
                If .HasVBProject Then
                    FileExtStr = ".xlsm": FileFormatNum = 52
                Else
                    FileExtStr = ".xlsx": FileFormatNum = 51
                End If
            Case 56: FileExtStr = ".xls": FileFormatNum = 56
            Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
            End Select
        End If
    End With

    TempFilePath = Environ$("temp") & "\"
    TempFileName = "Part of " & Sourcewb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    With Destwb
        .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
        On Error Resume Next
              
        With OutMail
            .To = dad
            .cc = mom
            .BCC = ""
            .subject = "This is the Subject line"
            .HTMLBody = "Hi all, <br> <br> Please find the <b>BRC Report</b> attached."
            .Attachments.Add Destwb.FullName
            .Send
        End With
        On Error GoTo 0
        .Close savechanges:=False
    End With

    Kill TempFilePath & TempFileName & FileExtStr

    Set OutMail = Nothing
    Set OutApp = Nothing

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub
 

Excel Facts

What do {} around a formula in the formula bar mean?
{Formula} means the formula was entered using Ctrl+Shift+Enter signifying an old-style array formula.
Sort by date Sort by votes
Hi @catscantuseexcel.
Welcome to the MrExcel forum. Please accept my warmest greetings and sincere hope that all is well.


According to the following:
catscantuseexcel said:
take the name from the open sheet. ... row 2 side by side in different colums. I would want it to loop through the row to find the sheet names
Click to expand...
The macro will read the names of the sheets to send from the active sheet, from row 2, but you didn't indicate which column, I'm going to assume that the names start in column 1 ("A").


Try the following macro:
VBA Code: 
Sub Mail_Sheets_Array()
  Dim Sourcewb As Workbook, Destwb As Workbook
  Dim sh As Worksheet
  Dim FileExtStr As String, TempFilePath As String, TempFileName As String
  Dim FileFormatNum As Long
  Dim OutApp As Object, OutMail As Object
  Dim TheActiveWindow As Window, TempWindow As Window
  Dim dad As String, mom As String, sName As String
  Dim j As Long, n As Long
  Dim TempSheets()

  With Application
      .ScreenUpdating = False
      .EnableEvents = False
  End With

  Set Sourcewb = ActiveWorkbook
  Set sh = ActiveSheet
  
  For j = 1 To sh.Cells(2, Columns.Count).End(1).Column
    sName = sh.Cells(2, j).Value
    If sName <> "" Then
      If Evaluate("ISREF('" & sName & "'!A1)") Then
        ReDim Preserve TempSheets(n)
        TempSheets(n) = sName
        n = n + 1
      End If
    End If
  Next
  If n = 0 Then
    MsgBox "There are no sheets to send"
    Exit Sub
  End If
  
  dad = Sheets("Send Mail").Cells(9, 2)
  mom = Sheets("Send Mail").Cells(20, 2)

  With Sourcewb
      Set TheActiveWindow = ActiveWindow
      Set TempWindow = .NewWindow
      '.Sheets(Array("Test Sheet", "Sheet Test")).Copy
      Sheets(TempSheets).Copy
  End With
  TempWindow.Close

  Set Destwb = ActiveWorkbook
  With Destwb
    If Val(Application.Version) < 12 Then
        FileExtStr = ".xls": FileFormatNum = -4143
    Else
      Select Case Sourcewb.FileFormat
        Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
        Case 52:
          If .HasVBProject Then
              FileExtStr = ".xlsm": FileFormatNum = 52
          Else
              FileExtStr = ".xlsx": FileFormatNum = 51
          End If
        Case 56: FileExtStr = ".xls": FileFormatNum = 56
        Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
      End Select
    End If
  End With

  TempFilePath = Environ$("temp") & "\"
  TempFileName = "Part of " & Sourcewb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")

  Set OutApp = CreateObject("Outlook.Application")
  Set OutMail = OutApp.CreateItem(0)
  With Destwb
    .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
    On Error Resume Next
    With OutMail
      .To = dad
      .Cc = mom
      .BCC = ""
      .Subject = "This is the Subject line"
      .HTMLBody = "Hi all, <br> <br> Please find the <b>BRC Report</b> attached."
      .Attachments.Add Destwb.FullName
      .Send
      '.Display
    End With
    On Error GoTo 0
    .Close savechanges:=False
  End With

  Kill TempFilePath & TempFileName & FileExtStr

  Set OutMail = Nothing
  Set OutApp = Nothing

  With Application
      .ScreenUpdating = True
      .EnableEvents = True
  End With
End Sub

--------------
Let me know the result and I'll get back to you as soon as I can.
Cordially
Dante Amor
--------------​
 
Upvote 1
Solution
DanteAmor said:
Hi @catscantuseexcel.
Welcome to the MrExcel forum. Please accept my warmest greetings and sincere hope that all is well.


According to the following:

The macro will read the names of the sheets to send from the active sheet, from row 2, but you didn't indicate which column, I'm going to assume that the names start in column 1 ("A").


Try the following macro:
VBA Code: 
Sub Mail_Sheets_Array()
  Dim Sourcewb As Workbook, Destwb As Workbook
  Dim sh As Worksheet
  Dim FileExtStr As String, TempFilePath As String, TempFileName As String
  Dim FileFormatNum As Long
  Dim OutApp As Object, OutMail As Object
  Dim TheActiveWindow As Window, TempWindow As Window
  Dim dad As String, mom As String, sName As String
  Dim j As Long, n As Long
  Dim TempSheets()

  With Application
      .ScreenUpdating = False
      .EnableEvents = False
  End With

  Set Sourcewb = ActiveWorkbook
  Set sh = ActiveSheet
 
  For j = 1 To sh.Cells(2, Columns.Count).End(1).Column
    sName = sh.Cells(2, j).Value
    If sName <> "" Then
      If Evaluate("ISREF('" & sName & "'!A1)") Then
        ReDim Preserve TempSheets(n)
        TempSheets(n) = sName
        n = n + 1
      End If
    End If
  Next
  If n = 0 Then
    MsgBox "There are no sheets to send"
    Exit Sub
  End If
 
  dad = Sheets("Send Mail").Cells(9, 2)
  mom = Sheets("Send Mail").Cells(20, 2)

  With Sourcewb
      Set TheActiveWindow = ActiveWindow
      Set TempWindow = .NewWindow
      '.Sheets(Array("Test Sheet", "Sheet Test")).Copy
      Sheets(TempSheets).Copy
  End With
  TempWindow.Close

  Set Destwb = ActiveWorkbook
  With Destwb
    If Val(Application.Version) < 12 Then
        FileExtStr = ".xls": FileFormatNum = -4143
    Else
      Select Case Sourcewb.FileFormat
        Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
        Case 52:
          If .HasVBProject Then
              FileExtStr = ".xlsm": FileFormatNum = 52
          Else
              FileExtStr = ".xlsx": FileFormatNum = 51
          End If
        Case 56: FileExtStr = ".xls": FileFormatNum = 56
        Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
      End Select
    End If
  End With

  TempFilePath = Environ$("temp") & "\"
  TempFileName = "Part of " & Sourcewb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")

  Set OutApp = CreateObject("Outlook.Application")
  Set OutMail = OutApp.CreateItem(0)
  With Destwb
    .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
    On Error Resume Next
    With OutMail
      .To = dad
      .Cc = mom
      .BCC = ""
      .Subject = "This is the Subject line"
      .HTMLBody = "Hi all, <br> <br> Please find the <b>BRC Report</b> attached."
      .Attachments.Add Destwb.FullName
      .Send
      '.Display
    End With
    On Error GoTo 0
    .Close savechanges:=False
  End With

  Kill TempFilePath & TempFileName & FileExtStr

  Set OutMail = Nothing
  Set OutApp = Nothing

  With Application
      .ScreenUpdating = True
      .EnableEvents = True
  End With
End Sub

--------------
Let me know the result and I'll get back to you as soon as I can.
Cordially
Dante Amor
--------------​
Click to expand...
thank you for your reply! I have actually solved the issue a bit by just defining which cells it needs to read to get the sheet name (as seen in the vba below). However, I have a new issue now: If, for example, there is no name listed in the cell for sheetName3 it will refuse to go on. However, I want the vba to just ignore that and move on to the next step in the vba. I would highly appreciate your input!

VBA Code: 
    Set Sourcewb = ActiveWorkbook
    
    sheetName1 = Sheets("MAIL").Range("C9").Value
    sheetName2 = Sheets("MAIL").Range("D9").Value
    sheetName2 = Sheets("MAIL").Range("E9").Value
    
    dad = Sheets("MAIL").Cells(9, 2)
    mom = Sheets("MAIL").Cells(20, 2)

    With Sourcewb
        Set TheActiveWindow = ActiveWindow
        Set TempWindow = .NewWindow
        .Sheets(Array(sheetName1, sheetName2, sheetName3)).Copy
    End With

    TempWindow.Close

    Set Destwb = ActiveWorkbook

    With Destwb
        If Val(Application.Version) < 12 Then
            FileExtStr = ".xls": FileFormatNum = -4143
        Else
            Select Case Sourcewb.FileFormat
            Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
            Case 52:
                If .HasVBProject Then
                    FileExtStr = ".xlsm": FileFormatNum = 52
                Else
                    FileExtStr = ".xlsx": FileFormatNum = 51
                End If
            Case 56: FileExtStr = ".xls": FileFormatNum = 56
            Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
            End Select
        End If
    End With
 
Upvote 0
If you had tried my code you would have seen that it solved the problem when a sheet does not exist.

-------------------
Your code has the following problem:
Rich (BB code): 
    sheetName1 = Sheets("MAIL").Range("C9").Value
    sheetName2 = Sheets("MAIL").Range("D9").Value
    sheetName2 = Sheets("MAIL").Range("E9").Value      'Here your variable has 2 and it should be 3
  
    dad = Sheets("MAIL").Cells(9, 2)
    mom = Sheets("MAIL").Cells(20, 2)

    With Sourcewb
        Set TheActiveWindow = ActiveWindow
        Set TempWindow = .NewWindow
        .Sheets(Array(sheetName1, sheetName2, sheetName3)).Copy
    End With
But still your code doesn't solve the problem if the sheet with the name you have in the cell doesn't exist.

----------------
I fix your code to check if the sheet really exists.

VBA Code: 
Sub Mail_Sheets_Array()
  Dim Sourcewb As Workbook, Destwb As Workbook
  Dim FileExtStr As String, TempFilePath As String, TempFileName As String
  Dim dad As String, mom As String
  Dim FileFormatNum As Long, n As Long
  Dim OutApp As Object, OutMail As Object
  Dim TheActiveWindow As Window, TempWindow As Window
  Dim TempSheets(), sheetNames As Variant, sName As Variant

  With Application
      .ScreenUpdating = False
      .EnableEvents = False
  End With

  Set Sourcewb = ActiveWorkbook
 
  sheetNames = Sheets("MAIL").Range("C9:E9").Value 'Fit to range of cells
 
  For Each sName In sheetNames
    If sName <> "" Then
      If Evaluate("ISREF('" & sName & "'!A1)") Then
        ReDim Preserve TempSheets(n)
        TempSheets(n) = sName
        n = n + 1
      End If
    End If
  Next
  If n = 0 Then
    MsgBox "There are no sheets to send"
    Exit Sub
  End If
 
  dad = Sheets("Send Mail").Cells(9, 2)
  mom = Sheets("Send Mail").Cells(20, 2)

  With Sourcewb
      Set TheActiveWindow = ActiveWindow
      Set TempWindow = .NewWindow
      Sheets(TempSheets).Copy
  End With
  TempWindow.Close

  Set Destwb = ActiveWorkbook
  With Destwb
    If Val(Application.Version) < 12 Then
        FileExtStr = ".xls": FileFormatNum = -4143
    Else
      Select Case Sourcewb.FileFormat
        Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
        Case 52:
          If .HasVBProject Then
              FileExtStr = ".xlsm": FileFormatNum = 52
          Else
              FileExtStr = ".xlsx": FileFormatNum = 51
          End If
        Case 56: FileExtStr = ".xls": FileFormatNum = 56
        Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
      End Select
    End If
  End With

  TempFilePath = Environ$("temp") & "\"
  TempFileName = "Part of " & Sourcewb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")

  Set OutApp = CreateObject("Outlook.Application")
  Set OutMail = OutApp.CreateItem(0)
  With Destwb
    .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
    On Error Resume Next
    With OutMail
      .To = dad
      .Cc = mom
      .BCC = ""
      .Subject = "This is the Subject line"
      .HTMLBody = "Hi all, <br> <br> Please find the <b>BRC Report</b> attached."
      .Attachments.Add Destwb.FullName
      .Send
      '.Display
    End With
    On Error GoTo 0
    .Close savechanges:=False
  End With

  Kill TempFilePath & TempFileName & FileExtStr

  Set OutMail = Nothing
  Set OutApp = Nothing

  With Application
      .ScreenUpdating = True
      .EnableEvents = True
  End With
End Sub


--------------
Regards
Dante Amor
--------------
 
Last edited:
Upvote 1
You must log in or register to reply here.

Similar threads

M
  • Question
Creating and emailing Excel sheet with only visible data
Replies
0
Views
186
mecerrato
M
H
  • Question
Macro to attached sheets without formulas
Replies
2
Views
388
howard
H
T
  • Solved
How to email a range in Excel
Replies
5
Views
823
kevin9999
K
Pinaceous
  • Question
VBA sending emails
Replies
1
Views
649
sijpie
sijpie
R
  • Question
VBA copy spredsheet contain pivot table as value
Replies
0
Views
361
Rafi_co
R

Forum statistics

Threads
1,215,069
Messages
6,122,954
Members
449,096
Latest member
Anshu121

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