Public Function Nth_Occurrence(range_look As Range, find_it As String, _
occurrence As Long, offset_row As Long, offset_col As Long) As Variant
Dim lCount As Long
Dim rFound As Range
On Error GoTo Err_ERROR
Set rFound = range_look.Cells(1, 1)
For lCount = 1 To occurrence
Set rFound = range_look.Find(find_it, rFound, xlValues, xlWhole)
Next lCount
Nth_Occurrence = rFound.Offset(offset_row, offset_col)
Exit Function
Err_ERROR:
Nth_Occurrence = "ERROR"
End Function
Sub CheckTotals(Time As String)
'Option Explicit
Dim Report As Worksheet, R1 As Worksheet, Special As Long
Set Report = Sheets("Sales Update")
Set R1 = Sheets(Time & " SALES REPORT")
'Check to see if TOTALS tie out
Dim NE As Boolean
Dim SE As Boolean
Dim SW As Boolean
Dim MW As Boolean
Dim W As Boolean
Dim HYM As Boolean
Dim INTL As Boolean
Dim SalesmenCount As Long, Salesman As String, SalesmanRow As Integer
Dim SalesDept As String, LastSalesmanRow As Integer, LoopCount As Integer
If Time = "09.30" Then
Special = 9
End If
If Time = "01.30" Then
Special = 10
End If
If Time = "03.45" Then
Special = 11
End If
'Determine if there is an "X" in "ACCUCHECK" for 9:30 AM report.
If Nth_Occurrence(Report.Range("A:B"), "NORTHEAST", 2, 0, Special) = "X" Then
NE = True
End If
If Nth_Occurrence(Report.Range("A:B"), "SOUTHEAST", 2, 0, Special) = "X" Then
SE = True
End If
If Nth_Occurrence(Report.Range("A:B"), "SOUTHWEST", 2, 0, Special) = "X" Then
SW = True
End If
If Nth_Occurrence(Report.Range("A:B"), "MIDWEST", 2, 0, Special) = "X" Then
MW = True
End If
If Nth_Occurrence(Report.Range("A:B"), "WEST", 2, 0, Special) = "X" Then
W = True
End If
If Nth_Occurrence(Report.Range("A:B"), "HYRUM", 2, 0, Special) = "X" Then
HYM = True
End If
If Nth_Occurrence(Report.Range("A:B"), "INTERNATIONAL", 2, 0, Special) = "X" Then
INTL = True
End If
'Find out which salesperson(s) is missing from each region in "Sales Update"
If NE = True Then
Call AddSalesman("NORTHEAST", Time)
End If
If SE = True Then
Call AddSalesman("SOUTHEAST", Time)
End If
If SW = True Then
Call AddSalesman("SOUTHWEST", Time)
End If
If MW = True Then
Call AddSalesman("MIDWEST", Time)
End If
If W = True Then
Call AddSalesman("WEST", Time)
End If
If HYM = True Then
Call AddSalesman("HYRUM", Time)
End If
If INTL = True Then
Call AddSalesman("INTERNATIONAL", Time)
End If
End Sub
Sub AddSalesman(Region As String, Time As String)
Dim SalesmenCount As Long, Salesman As String, SalesmanRow As Integer
Dim SalesDept As String, LastSalesmanRow As Integer, LoopCount As Integer
Dim rSelect As Range
Dim Report As Worksheet, R1 As Worksheet, Special As Long
Set Report = Sheets("Sales Update")
Set R1 = Sheets(Time & " SALES REPORT")
'Find out which salesperson(s) is missing from Region in "Sales Update"
SalesmenCount = 0
Salesman = Nth_Occurrence(R1.Range("A:A"), Region, 1, SalesmenCount, 1)
Do Until Salesman = ""
Salesman = Nth_Occurrence(R1.Range("A:A"), Region, 1, SalesmenCount, 1)
If Nth_Occurrence(Report.Range("A:B"), Salesman, 1, 0, 0) = "ERROR" Then
SalesmanRow = Application.Match(Region, Report.Range("A:A"), 0) + 2
Report.Activate
Report.Rows(SalesmanRow).Select
Selection.Copy
Selection.Insert Shift:=xlDown
Report.Range(Cells(SalesmanRow, 15), Cells(SalesmanRow, 18)).ClearContents
Report.Cells(SalesmanRow, 5) = 0
Report.Cells(SalesmanRow, 1) = Salesman
SalesmanRow = SalesmanRow - 1
SalesDept = Cells(SalesmanRow, 1).Value
LoopCount = 0
Do Until SalesDept = "NORTHEAST" Or SalesDept = "SOUTHEAST" Or SalesDept = "SOUTHWEST" _
Or SalesDept = "MIDWEST" Or SalesDept = "WEST" Or SalesDept = "HYRUM" _
Or SalesDept = "INTERNATIONAL" Or SalesDept = ""
Report.Range(Cells(SalesmanRow, 1), Cells(SalesmanRow, 2)).MergeCells = False
SalesmanRow = SalesmanRow + 1
SalesDept = Cells(SalesmanRow, 1).Value
LoopCount = LoopCount + 1
Loop
Report.Rows(SalesmanRow - LoopCount & ":" & SalesmanRow - 1).Select
Selection.Sort Key1:=Cells(SalesmanRow - LoopCount + 1, 1), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
SalesmanRow = Application.Match(Region, Report.Range("A:A"), 0) + 1
SalesDept = Cells(SalesmanRow, 1).Value
LoopCount = 0
Do Until SalesDept = "NORTHEAST" Or SalesDept = "SOUTHEAST" Or SalesDept = "SOUTHWEST" _
Or SalesDept = "MIDWEST" Or SalesDept = "WEST" Or SalesDept = "HYRUM" _
Or SalesDept = "INTERNATIONAL" Or SalesDept = ""
Report.Range(Cells(SalesmanRow, 1), Cells(SalesmanRow, 2)).MergeCells = True
SalesmanRow = SalesmanRow + 1
SalesDept = Cells(SalesmanRow, 1).Value
LoopCount = LoopCount + 1
Loop
Report.Range("A1").Select
SalesmanRow = Application.Match(Region, Report.Range("A:A"), 0) + 1
Set rSelect = Union(Report.Range(Cells(SalesmanRow, 1), Cells(SalesmanRow + LoopCount - 1, 5)), _
Report.Range(Cells(SalesmanRow, 7), Cells(SalesmanRow + LoopCount - 1, 9)))
Call CorrectFormatting(rSelect)
End If
SalesmenCount = SalesmenCount + 1
Loop
Report.Range("A1").Select
'End If
End Sub
Sub CorrectFormatting(Region As Range)
Region.Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
Range("A1:I1").Select
End Sub
Sub Copy_For_Email(v0930AM As Boolean, v0130PM As Boolean, v0345PM As Boolean)
Dim Report As Worksheet, R1 As Worksheet
Set Report = Sheets("Sales Update")
Set R1 = Sheets("COPY TO EMAIL")
Report.Activate
Report.Range("A:R").Copy
R1.Activate
R1.Paste Destination:=R1.Cells(1, 1)
R1.Range("A:R").Select
Selection.Copy
Selection.PasteSpecial xlValues
R1.Range("K:R").EntireColumn.Delete
Application.CutCopyMode = False
R1.Range("A1").Select
Call EmailWorksheet(v0930AM, v0130PM, v0345PM)
End Sub
Sub EmailWorksheet(v0930AM As Boolean, v0130PM As Boolean, v0345PM As Boolean)
' Don't forget to copy the function RangetoHTML in the module.
' Working in Office 2000-2010
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim Time As String
Dim LastRow As Integer
Dim R2 As Worksheet
Dim Address As String
Dim Distribution As String
Set R2 = Sheets("Sales Lookup & EMAIL LIST")
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set rng = Nothing
'Set rng = ActiveSheet.UsedRange
'You can also use a sheet name
Set rng = Sheets("COPY TO EMAIL").UsedRange
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Time = ""
If v0930AM = True Then
Time = "9:30 AM"
End If
If v0130PM = True Then
Time = "1:30 PM"
End If
If v0345PM = True Then
Time = "3:45 PM"
End If
If Time = "" Then
Time = InputBox("What time is it?", "TIME")
End If
Address = R2.Range("E2")
LastRow = 2
Do Until Address = ""
Distribution = Distribution & Address & "; "
LastRow = LastRow + 1
Address = R2.Cells(LastRow, 5).Value
Loop
On Error Resume Next
With OutMail
.To = Distribution
.CC = ""
.BCC = ""
.Subject = "Daily Beef Sales Update for " & Application.Text(Date, "mm/dd/yy") & " at " & Time
.HTMLBody = RangetoHTML(rng)
.Display 'or use .Send
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2010
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
Dim Time As String
TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a new workbook to past the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
'Close TempWB
TempWB.Close savechanges:=False
'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
