Editing a macro to include taking the file and opening an email


Board Regular
Mar 8, 2018
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:
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
  '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), "-")
        'if the sheet doesn't exist, create it!
        On Error Resume Next
        Set anyWS = ThisWorkbook.Worksheets(anyWSName)
        If Err <> 0 Then
          ThisWorkbook.Worksheets.Add _
          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.SaveAs Filename:=newName, _
       FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    End If


  '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
    '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
    'Application.WindowState = xlMaximized
    'Selection.Style = "Good"
  myGigSheet.Range(perfDayOfWeekCol & "1:" & perfNotesCol & 1).Style = "Good"
  'format row 2 (the labels row) for 1st 5 columns
    'Selection.Style = "Bad"
  myGigSheet.Range(perfDayOfWeekCol & "2:" & perfPayCol & 2).Style = "Bad"
  'format row 2 (the labels row) for columns F:I
    'Selection.Style = "Neutral"
  myGigSheet.Range(perfSopranoCol & "2:" & perfBassCol & 2).Style = "Neutral"
  'format remaining label entries on row 2
    'Selection.Style = "Input"
  myGigSheet.Range(perfContactNameCol & "2:" & perfNotesCol & 2).Style = "Input"
  'autofit the columns used
  '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
    End With
End Sub

Excel Facts

Select a hidden cell
Somehide hide payroll data in column G? Press F5. Type G1. Enter. Look in formula bar while you arrow down through G.

Forum statistics

Latest member

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