Macro to Copy certain WS's based on Key to a New WB and email

[Ben Mac]

OK, So I have a macro enabled worksheet with 2 Macros that make a set of new sheets that can be printed out a forms and signed by the person responsible for seeing that job completed. One Macro creates General actions from a list of Actions in sheet “general” and the other macro creates Minute actions from a list of actions in sheet “minutes”


I would like another Macro that will look at a list of initials in the first sheet (Sheet = Attendance, Row = I) and then search the cell E3 for all the sheets between sheet “general” and sheet “minutes” (these are the general Actions sheets generated by the first macro) and make a new workbook for each person from the list of initials with all the actions (action sheets e.g. “Action 1 General”) assigned to them saved in it.


I would then want the same Macro to look at cell C5 for all the sheets between sheet “minutes” and sheet “signoff” (these are the minute Actions sheets generated by the second macro) and add the actions (action sheets e.g. “Action 1 Minutes”) to the workbook already created for each person from the list on the first sheet.

I would like the Macro to then save these new Workbooks to a directory of my choosing

Points of Note:

The two Macros need to be run manually before this Macro could be run. And are located on the ribbon
This Macro could be a third Button on the ribbon
I would not want a workbook created if there were no actions for anybody on the Initials List on the first page
Lastly, it would be nice if the workbook for each person Initialed could be sent their workbook of actions automatically. So I have included on the first sheet, both their full names in the first column and their email in the last column (J)


I Hope someone can help, I’ve worked my way through the first set of Macros in my workbook, and although I have had ideas of how I could do this, e.g. making a list somewhere of what worksheets are needed to be saved using VLookup or writing a macro to look at the list of Initials and searching cells to find the sheet names of those worksheets it’s not quite coming together in my head.

However, once I had that list I thought I could use the Macro I found on this site (Article id=359 to look) which I could use to look at that list and save them to the new workbooks. Don’t know how I could email them though. That’s beyond me.

Anyway I have attached a small example of my workbook, if anyone can help, that would be much appreciated.





Thanks
Ben

[mdmackillop]

Need input/confirmation at "@@@@@" and thorough testing

Option Explicit
Option Base 1
Dim pth$
Sub Tasks()
    Dim r As Range, cel As Range
    Dim ShtsG(), ShtsM()
    Dim Arr()
    Dim sh As Worksheet
    Dim j%, k%, g%, m%
    
    Application.ScreenUpdating = False
    On Error Resume Next
    MkDir ActiveWorkbook.Path & "\Actions"      '@@@@@@@@@@  Creates folder
    On Error GoTo 0
    pth = ActiveWorkbook.Path & "\Actions\"    '@@@@@@@@@@
    Call ClearOldFiles
    Exit Sub
    ReDim ShtsG(1 To Sheets.Count)
    ReDim ShtsM(1 To Sheets.Count)


    'Get General/Minute sheets
    For Each sh In Sheets
        If sh.Name Like "Action * General" Then
            g = g + 1
            ShtsG(g) = sh.Name
        End If
        If sh.Name Like "Action * Minutes" Then
            m = m + 1
            ShtsM(m) = sh.Name
        End If
    Next sh
    ReDim Preserve ShtsG(g)
    ReDim Preserve ShtsM(m)


    'Get Initials
    With Sheets("Attendance")
        Set r = Range(.Cells(5, 9), .Cells(Rows.Count, 9).End(xlUp))
    End With
    'Check for initials
    ReDim Arr(g + m)
    For Each cel In r
        'General
        For j = 1 To g
            If Sheets(ShtsG(j)).Cells(3, 5) = cel Then
                k = k + 1
                Arr(k) = ShtsG(j)
            End If
        Next j
        'Minutes
        For j = 1 To m
            If Sheets(ShtsM(j)).Cells(5, 3) = cel Then
                k = k + 1
                Arr(k) = ShtsM(j)
            End If
        Next j
        'Create action array
        If k > 0 Then
            ReDim Preserve Arr(k)
            Sheets(Arr).Copy
            With ActiveWorkbook
                .SaveAs pth & cel & ".xlsx", FileFormat:=xlOpenXMLWorkbook
                .Close
            End With
        End If
        'Reset array etc.
        ReDim Arr(g + m): k = 0
    Next cel
    Call Emails
    Application.ScreenUpdating = True
End Sub




Sub ClearOldFiles()
    Dim fNme As String
    pth = ActiveWorkbook.Path & "\Actions\"
    On Error GoTo Exits
    fNme = Dir(pth & "*.xlsx")
        Do
            Kill pth & fNme
            fNme = Dir
        Loop Until fNme = ""
Exits:
End Sub


Sub Emails()
    Dim fNme$, Init$, Addr$, Att$, Recip$
    Dim c As Range
    
    fNme = Dir(pth & "*.xlsx")
    Init = Split(fNme, ".")(0)
    With Sheets("Attendance")
        Do
            Set c = .Columns(9).Find(Init, lookat:=xlWhole)
            Addr = Split(c.Offset(, -8), " ")(0)
            Recip = c.Offset(, 1)
            Att = pth & fNme
            Call CDO_Mail_Small_Text_2(Addr, Recip, Att)
            fNme = Dir
        Loop Until fNme = ""
    End With
End Sub

'In separate module
Option Explicit
'https://www.rondebruin.nl/win/s1/cdo.htm


'If you have a GMail account then you can try this example to use the GMail smtp server
'The example will send a small text message
'You must change four code lines before you can test the code


'.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "Full GMail mail address"
'.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "GMail password"


'Use your own mail address to test the code in this line
'.To = "Mail address receiver"


'Change YourName to the From name you want to use
'.From = """YourName"" <Reply@something.nl>"


'If you get this error : The transport failed to connect to the server
'then try to change the SMTP port from 25 to 465


'Possible that you must also enable the "Less Secure" option for GMail
'https://www.google.com/settings/security/lesssecureapps


Sub CDO_Mail_Small_Text_2(Addr, Recip, Att)
    Dim iMsg As Object
    Dim iConf As Object
    Dim strbody As String
    Dim Flds As Variant


    Set iMsg = CreateObject("CDO.Message")
    Set iConf = CreateObject("CDO.Configuration")


    iConf.Load -1    ' CDO Source Defaults
    Set Flds = iConf.Fields
    With Flds
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
        .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "SomeOne@gmail.com"  '@@@@@@@@@@@
        .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "Password"           '@@@@@@@@@@@
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com"       '@@@@@@@@@@@


        .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
        .Update
    End With


    strbody = "Hi " & Addr & vbNewLine & vbNewLine & _
        "This is line 1" & vbNewLine & _
        "This is line 2" & vbNewLine & _
        "This is line 3" & vbNewLine & _
        "This is line 4"                                    '@@@@@@@@@@@@@@@@@


    With iMsg
        Set .Configuration = iConf
        .To = Recip
        .CC = ""
        .BCC = ""
        ' Note: The reply address is not working if you use this Gmail example
        ' It will use your Gmail address automatic. But you can add this line
        ' to change the reply address  .ReplyTo = "Reply@something.nl"
        .From = """YourName"" <Reply@something.nl>" '@@@@@@@@@@@@@@@@@@
        .Subject = "Important message"              '@@@@@@@@@@@@@@@@@@
        .TextBody = strbody
        .addAttachment Att
        .Send
    End With
    
    Set iMsg = Nothing
    Set iConf = Nothing
    Set Flds = Nothing
End Sub