Hi Excel Geniuses!
I have a very complex (for me) macro that was built for me, and I want to make a change. This macro looks at my main "Gig Sheet," searches for the singer's name, creates a new file that basically pulls out each singer's gigs to their own sheet, and then I *think* it pulls the sheet out of my main document, and saves it in a file. Then it deletes the sheet from the main sheet (or maybe when it's moved, it deletes it).
OK - so I want it to pull the sheet out, open a message with the subject "Gig Sheet" and the current date, and leave it for me to send. Ideally, it would also put text in the body of the email, and pull the email address from the sheet, but if that's a pipe dream, I understand.
I see code online for doing this, but I'm not sure where it should go in my macro. Can someone help?
Here's my code:
I have a very complex (for me) macro that was built for me, and I want to make a change. This macro looks at my main "Gig Sheet," searches for the singer's name, creates a new file that basically pulls out each singer's gigs to their own sheet, and then I *think* it pulls the sheet out of my main document, and saves it in a file. Then it deletes the sheet from the main sheet (or maybe when it's moved, it deletes it).
OK - so I want it to pull the sheet out, open a message with the subject "Gig Sheet" and the current date, and leave it for me to send. Ideally, it would also put text in the body of the email, and pull the email address from the sheet, but if that's a pipe dream, I understand.
I see code online for doing this, but I'm not sure where it should go in my macro. Can someone help?
Here's my code:
VBA Code:
Option Explicit
'Judi, by moving these definitions out of the BuildIndividualWorkbooks() sub
'and placing them here in the module ahead of all subs/functions
'we make them available to all subs/functions in this code module.
'
' This way we don't have to redefine any of them for the new FormatGigSheet()
' sub that I've placed into this same code module.
'
'you could even make them available to any sub/function in any code module
'in the entire workbook by declaring them as "Public Const" instead of just "Const"
Const mainFirstEventEntryRow = 3 ' assumes labels in row 1
Const mainDayOfWeekCol = "A"
Const mainDateCol = "B"
Const mainEventCol = "C"
Const mainTimeCol = "D"
Const mainPayCol = "K"
Const mainSopranoCol = "L"
Const mainAltoCol = "M"
Const mainTenorCol = "N"
Const mainBassCol = "O"
Const mainContactNameCol = "AP"
Const mainVenueCol = "As"
Const mainAddressCol = "AT"
Const mainCityCol = "AU"
Const mainZipCol = "AV"
Const mainNotesCol = "AW"
Const firstPerformerCol = "L"
Const lastPerformerCol = "O"
'we define these separately so that individual sheets
'can have a different layout if desired
'for the moment, we use same columns layout
'data entry starts on row 3
Const perfFirstDataRow = 3
Const perfDayOfWeekCol = "A"
Const perfDateCol = "B"
Const perfEventCol = "C"
Const perfTimeCol = "D"
Const perfPayCol = "E"
Const perfSopranoCol = "F"
Const perfAltoCol = "G"
Const perfTenorCol = "H"
Const perfBassCol = "I"
Const perfContactNameCol = "J"
Const perfVenueCol = "K"
Const perfAddressCol = "L"
Const perfCityCol = "M"
Const perfZipCol = "N"
Const perfNotesCol = "O"
Sub CMEBuildIndividualWorkbooks()
Dim mainWS As Worksheet
Dim mainLastRow As Long
Dim mainLastCol As Long
Dim mainRLC As Long ' main data rows loop counter
Dim perfNamesLC As Long ' performers loop counter
Dim anyWSName As String
Dim anyWS As Worksheet
Dim anyWSNextRow As Long
Dim invalidCharList(1 To 8) As String
Dim invLC As Long ' invalidCharList() array loop counter
'for worksheet sorting
Dim sortLoop1 As Integer
Dim sortLoop2 As Integer
'for working with the sheets and the
'new workbooks that will be created from them
Dim sheetsCreated() As String
Dim myPath As String
Dim newName As String
Dim testName As String
'get the path to this workbook
myPath = ThisWorkbook.Path
If Right(myPath, 1) <> Application.PathSeparator Then
myPath = myPath & Application.PathSeparator
End If
'assumes all "Days" entries have an entry in them
Set mainWS = Sheet20 ' [Master Gig Sheet]
mainLastRow = mainWS.Range(mainDayOfWeekCol & Rows.Count).End(xlUp).Row
If mainLastRow < mainFirstEventEntryRow Then
MsgBox "No data to work with.", vbOKOnly + vbInformation, "Quitting"
Set mainWS = Nothing
Exit Sub
End If
'
'fill the invalid worksheet name characters array
'borrow mainRLC for this
invalidCharList(1) = "/"
invalidCharList(2) = "\"
invalidCharList(3) = "|"
invalidCharList(4) = "?"
invalidCharList(5) = ":"
invalidCharList(6) = "*"
invalidCharList(7) = "["
invalidCharList(8) = "]"
'this is where we delete all past information on any existing
'individual performer's record worksheet.
'Assumes that there are ONLY the main sheet and individual sheets
'in the workbook. If there are others, we need to know about them
'so we can exclude them from this process.
GoTo Skip01
For Each anyWS In ThisWorkbook.Worksheets
'this shows how to exclude other sheets also
If anyWS.Name <> mainWS.Name And _
anyWS.Name <> "Sheet1" And _
anyWS.Name <> "Sheet2" Then
anyWSNextRow = anyWS.Range(perfDayOfWeekCol & Rows.Count).End(xlUp).Row
If anyWSNextRow >= perfFirstDataRow Then
anyWS.Range("A" & perfFirstDataRow & ":A" & anyWSNextRow).Clear
End If
End If ' end worksheet name check
Next ' end anyWS loop
Skip01:
'breathe life into this array
ReDim sheetsCreated(1 To 1)
'improve performance
Application.ScreenUpdating = False
For mainRLC = mainFirstEventEntryRow To mainLastRow
'begin the work
For perfNamesLC = Range(firstPerformerCol & 1).Column To Range(lastPerformerCol & 1).Column
'is there a name in the cell?
If Not IsEmpty(mainWS.Cells(mainRLC, perfNamesLC)) Then
'use the name as the sheet name, remove leading/trailing white space
anyWSName = Trim(mainWS.Cells(mainRLC, perfNamesLC))
If Len(anyWSName) > 31 Then
anyWSName = Left(anyWSName, 31) ' Excel limitation
End If
'replace any invalid characters in the name with a dash
'so that we don't generate an error when naming new sheets
For invLC = LBound(invalidCharList) To UBound(invalidCharList)
anyWSName = Replace(anyWSName, invalidCharList(invLC), "-")
Next
'if the sheet doesn't exist, create it!
On Error Resume Next
Set anyWS = ThisWorkbook.Worksheets(anyWSName)
If Err <> 0 Then
Err.Clear
ThisWorkbook.Worksheets.Add _
After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
Set anyWS = ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
anyWS.Name = anyWSName
'record this sheet as added to the workbook
sheetsCreated(UBound(sheetsCreated)) = anyWS.Name
'make room for the next one we may have to create
ReDim Preserve sheetsCreated(1 To UBound(sheetsCreated) + 1)
'set up basic entries on the new sheet
anyWS.Range(perfDayOfWeekCol & 1) = "Performer:"
anyWS.Range(perfDateCol & 1) = anyWSName
anyWS.Range(perfDayOfWeekCol & perfFirstDataRow - 1) = "Days"
anyWS.Range(perfDateCol & perfFirstDataRow - 1) = "Dates"
anyWS.Range(perfEventCol & perfFirstDataRow - 1) = "Event"
anyWS.Range(perfTimeCol & perfFirstDataRow - 1) = "Time"
anyWS.Range(perfPayCol & perfFirstDataRow - 1) = "Total Pay"
anyWS.Range(perfSopranoCol & perfFirstDataRow - 1) = "Soprano"
anyWS.Range(perfAltoCol & perfFirstDataRow - 1) = "Alto"
anyWS.Range(perfTenorCol & perfFirstDataRow - 1) = "Tenor"
anyWS.Range(perfBassCol & perfFirstDataRow - 1) = "Bass"
anyWS.Range(perfContactNameCol & perfFirstDataRow - 1) = "Contact Name"
anyWS.Range(perfVenueCol & perfFirstDataRow - 1) = "Venue"
anyWS.Range(perfAddressCol & perfFirstDataRow - 1) = "Address"
anyWS.Range(perfCityCol & perfFirstDataRow - 1) = "City"
anyWS.Range(perfZipCol & perfFirstDataRow - 1) = "Zip"
anyWS.Range(perfNotesCol & perfFirstDataRow - 1) = "Notes"
End If
On Error GoTo 0
'copy entries from main WS to the performer's sheet
anyWSNextRow = _
anyWS.Range(perfDayOfWeekCol & Rows.Count).End(xlUp).Row + 1
'copy Days information
anyWS.Range(perfDayOfWeekCol & anyWSNextRow) = _
mainWS.Range(mainDayOfWeekCol & mainRLC)
'duplicate date(s) format and copy the information
anyWS.Range(perfDateCol & anyWSNextRow).NumberFormat = _
mainWS.Range(mainDateCol & mainRLC).NumberFormat
anyWS.Range(perfDateCol & anyWSNextRow) = _
mainWS.Range(mainDateCol & mainRLC)
'copy the Event information
anyWS.Range(perfEventCol & anyWSNextRow) = _
mainWS.Range(mainEventCol & mainRLC)
'duplicate time format and copy the information
anyWS.Range(perfTimeCol & anyWSNextRow).NumberFormat = _
mainWS.Range(mainTimeCol & mainRLC).NumberFormat
anyWS.Range(perfTimeCol & anyWSNextRow) = _
mainWS.Range(mainTimeCol & mainRLC)
'duplicate pay format and copy the information
anyWS.Range(perfPayCol & anyWSNextRow).NumberFormat = _
mainWS.Range(mainPayCol & mainRLC).NumberFormat
anyWS.Range(perfPayCol & anyWSNextRow) = _
mainWS.Range(mainPayCol & mainRLC)
'copy the Soprano information
anyWS.Range(perfSopranoCol & anyWSNextRow) = _
mainWS.Range(mainSopranoCol & mainRLC)
'copy the Alto information
anyWS.Range(perfAltoCol & anyWSNextRow) = _
mainWS.Range(mainAltoCol & mainRLC)
'copy the Tenor information
anyWS.Range(perfTenorCol & anyWSNextRow) = _
mainWS.Range(mainTenorCol & mainRLC)
'copy the Bass information
anyWS.Range(perfBassCol & anyWSNextRow) = _
mainWS.Range(mainBassCol & mainRLC)
'copy the Contact Name information
anyWS.Range(perfContactNameCol & anyWSNextRow) = _
mainWS.Range(mainContactNameCol & mainRLC)
'copy the Venue information
anyWS.Range(perfVenueCol & anyWSNextRow) = _
mainWS.Range(mainVenueCol & mainRLC)
'copy the Address information
anyWS.Range(perfAddressCol & anyWSNextRow) = _
mainWS.Range(mainAddressCol & mainRLC)
'copy the City information
anyWS.Range(perfCityCol & anyWSNextRow) = _
mainWS.Range(mainCityCol & mainRLC)
'copy the Zip information
anyWS.Range(perfZipCol & anyWSNextRow).NumberFormat = _
mainWS.Range(mainZipCol & mainRLC).NumberFormat
anyWS.Range(perfZipCol & anyWSNextRow) = _
mainWS.Range(mainZipCol & mainRLC)
'copy the Notes information
anyWS.Range(perfNotesCol & anyWSNextRow) = _
mainWS.Range(mainNotesCol & mainRLC)
End If ' end check for empty name cell
Next ' end perfNamesLC loop
Next ' end mainRLC loop
'
'now move the created worksheets into separate workbooks
'and remove them from this one.
'use mainRLC to work through the sheetsCreated() array
For mainRLC = LBound(sheetsCreated) To UBound(sheetsCreated)
If sheetsCreated(mainRLC) <> "" Then
'******************************************************
'Do final formatting of the created sheet
'*********************
'call the formatting routine, passing it the name
'of the sheet we just created and filled
FormatGigSheet sheetsCreated(mainRLC)
'Add the individual pay
AddPay Worksheets(sheetsCreated(mainRLC))
'******************************************************
'have a sheet name, look for a workbook with
'same name in this same folder
'and hunt it down and kill the little critter!
newName = myPath & sheetsCreated(mainRLC) & ".xlsx"
testName = Dir(newName)
If testName <> "" Then
Kill testName
End If
'then copy this sheet to a new book and save it
'with the appropriate name
'create the new workbook with a single sheet [Sheet1]
Workbooks.Add (xlWBATWorksheet)
'move the sheet out of this workbook and into the other
ThisWorkbook.Sheets(sheetsCreated(mainRLC)).Move Before:=ActiveWorkbook.Sheets(1)
'save the workbook (will leave an extra sheet in it, but oh well...)
Application.DisplayAlerts = False
ActiveWorkbook.Sheets("Sheet1").Delete
ActiveWorkbook.SaveAs Filename:=newName, _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
ActiveWorkbook.Close
End If
Next
mainWS.Activate
'housekeeping and cleanup
Set anyWS = Nothing
Set mainWS = Nothing
'announce job done
MsgBox "Individual Performer's Sheet Updating Completed", _
vbOKOnly + vbInformation, "Task Completed"
End Sub
Sub FormatGigSheet(whichSheet As String)
'INPUT: whichSheet is a string (text) containing name of the sheet to format
'OUTPUT: 'whichSheet' is formatted in standard format defined in this Sub
'
Dim myGigSheet As Worksheet
Dim lastRow As Long
Set myGigSheet = ThisWorkbook.Worksheets(whichSheet)
With myGigSheet.Cells.Font
.Name = "Calibri"
.Size = 10
'because all we were really interested in is
'the font used and its size, we could have
'deleted the following property settings, but
'I've left them in place "just because".
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With
'we need lastRow defined for .Bold function and later for
'bordering the individual entries
lastRow = myGigSheet.Range(perfDayOfWeekCol & Rows.Count).End(xlUp).Row
'Format the day of the week as bold
' RECORDED MACRO CODE
'Range("A3:A7").Select
'Selection.Font.Bold = True
'Recorded macro code replacement code.
'check to see if any daily entries actually placed onto this sheet
If lastRow >= perfFirstDataRow Then
'have individual entries, go ahead and make text bold
myGigSheet.Range(perfDayOfWeekCol & perfFirstDataRow & ":" & _
perfDayOfWeekCol & lastRow).Font.Bold = True
End If
'format the first row based on known references to
'the first and last columns used
'Range("A1:O1").Select
'Application.WindowState = xlMaximized
'Selection.Style = "Good"
myGigSheet.Range(perfDayOfWeekCol & "1:" & perfNotesCol & 1).Style = "Good"
'format row 2 (the labels row) for 1st 5 columns
'Range("A2:E2").Select
'Selection.Style = "Bad"
myGigSheet.Range(perfDayOfWeekCol & "2:" & perfPayCol & 2).Style = "Bad"
'format row 2 (the labels row) for columns F:I
'Range("F2:I2").Select
'Selection.Style = "Neutral"
myGigSheet.Range(perfSopranoCol & "2:" & perfBassCol & 2).Style = "Neutral"
'format remaining label entries on row 2
'Range("J2:O2").Select
'Selection.Style = "Input"
myGigSheet.Range(perfContactNameCol & "2:" & perfNotesCol & 2).Style = "Input"
'autofit the columns used
'Cells.Select
'Cells.EntireColumn.AutoFit
myGigSheet.Cells.EntireColumn.AutoFit
'take care of the borders for all used cells in row 2
'not going to duplicate old code here - too darned long!
'basically changing Selection to With and specified range
With myGigSheet.Range("A2:O2")
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Color = -8421505
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Color = -8421505
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Color = -8421505
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Color = -8421505
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Color = -8421505
.TintAndShade = 0
.Weight = xlThin
End With
.Borders(xlInsideHorizontal).LineStyle = xlNone
End With ' end of whole range With block of A2:O2
'check to see if any daily entries actually placed onto this sheet
If lastRow >= perfFirstDataRow Then
'we have daily entries, set up their borders
With myGigSheet.Range(perfDayOfWeekCol & perfFirstDataRow & ":" & _
perfNotesCol & lastRow)
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
End With ' end of whole range With block for individual entries
End If ' end of test for any individual entries
'good housekeeping
Set myGigSheet = Nothing ' releases used RAM back to system
End Sub
Sub AddPay(shtO As Worksheet)
With shtO
.Columns("F:F").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
.Range("F2").Value = "Singer Pay"
With .Range("F3:F" & .Cells(.Rows.Count, "B").End(xlUp).Row)
.FormulaR1C1 = "=RC[-1]*0.80/4"
.Value = .Value
With .Offset(.Cells.Count, 0).Resize(1)
.FormulaR1C1 = "=SUM(R3C:R[-1]C)"
.Value = .Value
.NumberFormat = "_($* #,##0.00_);_($* (#,##0.00);_($* ""-""??_);_(@_)"
End With
.NumberFormat = "_($* #,##0.00_);_($* (#,##0.00);_($* ""-""??_);_(@_)"
End With
.Columns("F:F").AutoFit
End With
End Sub
