PDA

View Full Version : Macro to Copy certain WS's based on Key to a New WB and email



Ben Mac
08-07-2017, 10:18 PM
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
08-08-2017, 02:40 AM
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