Hi, Fern Jones!
Here's my Frankenstein (yesterday I watched on TV Young Frankenstein with & by Mel Brooks, so the name applies).
With pieces of a couple of posts I came up with this file:
https://dl.dropboxusercontent.com/u/60558749/Need%20help%20organizing%20Excel%20files%20%28for%20Fern%20Jones%20at%20chandoo.org%29.xlsm
1st worksheet: Master
- with a dynamic named range MasterTable
- with 2 command buttons, one for filling the 2nd worksheet and another for resetting filters
2nd worksheet: Filtered
- with a dynamic named range FilteredTable
- with 2 command buttons, one for viewing mails from 3rd worksheet and another for sending mails
3rd worksheet: Mail
- with a dynamic named range MailTable
This the code:
-----
Option Explicit
' constants
Const gksWSMaster = "Master"
Const gksMaster = "MasterTable"
Const gksWSFiltered = "Filtered"
Const gksFiltered = "FilteredTable"
Const gksWSMail = "Mail"
Const gksMail = "MailTable"
Const gksSeparator = " - "
Const gksWBOffer = "Offer_"
Const gksWBOfferExtension = ".xlsx"
' declarations
Dim grngMaster As Range, grngFiltered As Range, grngMail As Range
Dim gsOffer As String, gsWBOffer As String, gdOffer As Date
Sub CreateFiltered()
' constants
' declarations
Dim rw As Range
Dim lFiltered As Long
Dim I As Long, J As Integer
' start
Set grngMaster = Worksheets(gksWSMaster).Range(gksMaster)
Set grngFiltered = Worksheets(gksWSFiltered).Range(gksFiltered)
With grngFiltered
If .Rows.Count > 1 Then Range(.Rows(2), .Rows(.Rows.Count)).ClearContents
End With
lFiltered = 1
' process
With grngMaster.SpecialCells(xlCellTypeVisible)
For Each rw In .Rows
If rw.Row <> 1 Then
lFiltered = lFiltered + 1
For J = 1 To rw.Columns.Count
grngFiltered.Cells(lFiltered, J).Value = .Cells(rw.Row, J).Value
Next J
End If
Next rw
End With
BuildOfferText
BuildOfferWorkbook
' end
Set grngMaster = Nothing
Beep
End Sub
Private Sub BuildOfferText()
' constants
' declarations
Dim I As Long
' start
gsOffer = ""
' process
With grngFiltered
For I = 2 To .Rows.Count
If gsOffer <> "" Then gsOffer = gsOffer & vbCrLf
gsOffer = gsOffer & .Cells(I, 3).Value & gksSeparator & _
.Cells(I, 4).Value & gksSeparator & _
Format(.Cells(I, 5).Value, "ddd dd-mmm-yyyy"
& gksSeparator & _
Format(.Cells(I, 6).Value, "ddd dd-mmm-yyyy"
& gksSeparator & _
.Cells(I, 7).Value & gksSeparator & .Cells(I, 8).Value
Next I
End With
' end
End Sub
Sub BuildOfferWorkbook()
' constants
' declarations
Dim wb As Workbook, ws As Worksheet
Dim I As Integer
' start
With Application
.DisplayAlerts = False
.ScreenUpdating = False
End With
' name
gdOffer = Now()
gsWBOffer = ThisWorkbook.Path & Application.PathSeparator & _
gksWBOffer & Format(gdOffer, "yyyymmdd_hhmmss"
& gksWBOfferExtension
' process
Set ws = ThisWorkbook.Worksheets(gksWSFiltered)
Set wb = Workbooks.Add
With wb
' paste in target
ws.Copy .Sheets(1)
' command buttons
With .Worksheets(1)
For I = .Shapes.Count To 1 Step -1
.Shapes(I).Delete
Next I
End With
' extra worksheets
For I = .Worksheets.Count To 2 Step -1
.Worksheets(I).Delete
Next I
' save & close
.SaveAs gsWBOffer
.Close
End With
' end
Set ws = Nothing
Set wb = Nothing
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
Sub ResetFilters()
ActiveSheet.ShowAllData
End Sub
Sub MailStuff(pbSend As Boolean)
' constants
Const ksSubject = "Mail subject"
Const ksText1 = "Dear sir/madame:"
Const ksText2 = "Regarding this reference: "
Const ksText3 = "This is the related offer information (Code, Name, Effective date, Expiration date, Amount, Other data)):"
Const ksText4 = "Signed by XXX."
' declarations
Dim olApp As Object, olMail As Object
Dim sMail As String, sText As String
Dim I As Integer, J As Integer, A As String, bOk As Boolean
Dim sOffer As String
' start
Set grngFiltered = Worksheets(gksWSFiltered).Range(gksFiltered)
Set grngMail = Worksheets(gksWSMail).Range(gksMail)
Set olApp = CreateObject("Outlook.Application"
' process
With grngMail
For I = 2 To .Rows.Count
' create mail
Set olMail = olApp.CreateItem(0)
sMail = .Cells(I, 1).Value
' build body
sText = ksText1 & vbCrLf & _
.Cells(I, 1).Value & vbCrLf & .Cells(I, 2).Value & vbCrLf & _
.Cells(I, 3).Value & vbCrLf & .Cells(I, 4).Value & vbCrLf & _
.Cells(I, 5).Value & vbCrLf & .Cells(I, 6).Value & vbCrLf & _
vbCrLf & _
ksText2 & "Offers sent on " & _
Format(gdOffer, "ddd dd-mmm-yyyy hh:mm:ss"
& _
vbCrLf & vbCrLf & _
ksText3 & vbCrLf & _
gsOffer & _
vbCrLf & vbCrLf & _
ksText4
' view/send mail
'=====
'This block of code written by Ron de Bruin, copied from
'http://msdn.microsoft.com/en-us/library/ff458119(office.11).aspx#odc_office_UseExcelObjectModeltoSendMail_Introduction
On Error Resume Next
' Change the body and subject in the macro before you run it.
With olMail
.to = sMail
.CC = ""
.BCC = ""
.Subject = ksSubject
.Body = sText
'You're not sending an attachment, so I commented this out
.Attachments.Add gsWBOffer
' You can add other files by uncommenting the following line.
'.Attachments.Add ("C:test.txt"
' In place of the following statement, you can use ".Display" to
' display the mail.
If pbSend Then .Send Else .Display
DoEvents
End With
On Error GoTo 0
'=======
' destroy mail
Set olMail = Nothing
Next I
End With
' end
Set olApp = Nothing
Set grngMail = Nothing
Set grngFiltered = Nothing
Beep
End Sub
-----
What I think it lacks but it's your homework is to build a user form for making more secure and user friendly the input of data at worksheet Master.
Just advise if any issue.
Regards!
