Sample Work
Sample Visual Basic for Applications (VBA) Code for MS Excel
The following original code demonstrates some programming techniques and object naming, which are meaningful and in accordance with a predefined naming convention.
Option Explicit
Dim RowValue, Found, LastCellInColAddress, CellObject
Const strSalesListToday = "SalesList"
Const strSalesListPrev = "SalesListOld"
Const strFilePath = "\\Data2002A\Internet\SalesSearch\"
' This module will set the default or user variable values
' The values are taken from the worksheet named VariableValues.
' When user values are left blank (empty string),
' then the default values are used.
' Dr. M. A. Meshkot Feb 2002
' Ref 13801113
Public gbolUseDefaultValues As Boolean
Public gstrNewList As String
Public gstrPrevList As String
Public gstrSelectedList As String
Public gbolDeleteOldList As Boolean
Public gstrFilter1 As String
Public gstrFilter2 As String
Public gstrFilter3 As String
Public gstrFilter4 As String
Public gstrFilePath As String
Public gstrNewListFilename As String
Public gstrPrevListFilename As String
Public gstrListSheetName As String
Public gstrAttachmentPath As String
Public gintListColWidth As Integer
Public gintDataCleanColumnRelative As Integer
Public gintDataCompareColumnRelative As Integer
Public gintEmailBatchSize As Integer
Public gIntShowScreenInterval As Integer
Public gstrFilenameFormat As String
Public gintMarkColumnNumberSelectRelative As Integer
Public gintMarkColumnNumberNewRelative As Integer
Public gintTempColumnNumberRelative As Integer
Public gintPasteColumnNumber As Integer
Public gintAttachmentAdsColNumberRel As Integer
Public gMarkColourNew As Integer
Public gMarkColourSelect As Integer
Public gMarkColourCopied As Integer
Public gMarkColourAfterEmail1 As Integer
Public gMarkColourBeforeEmail2 As Integer
Public gMarkColourAfterEmail2 As Integer
Public gintEmail1Email2Delay As Integer
Public Const colWhite = &H80000014
Public Const colGrey = 15
Public Const colDarkGrey = 48
Public Const colYellow = 6
Public Const colPink = 7
Public Const colFilterOn = &H80FF80
Public Const colFilterOff = &H8000000F
Public Const cSelect = "Select Worksheet"
Public Const bolNew = True
Public Const bolPrev = False
Public Const cDataColCount = 14
Public Const cFollowUpColRelative = 18 ' Follow-up column relative to col. A=0
Public Const cEmail1Lines = 50
Public Const cEmail2Lines = 35
Public Const cMaxAttachments = 10
Public Const cZero = "Zero"
Public Const cNoDataSource = "No Data Source Worksheet has been selected"
Public Const quote = """"
Public gstrColHeading(1 To cDataColCount) As String
Public gstrEmail1HTMLBodyLine(1 To cEmail1Lines) As String
Public gstrEmail2HTMLBodyLine(1 To cEmail2Lines) As String
Public Type Attachment
ID(1 To cMaxAttachments) As String
FilePath(1 To cMaxAttachments) As String
End Type
Public gstrAttachment As Attachment
Public gstrSourceDataWorksheetName As String
Public gvarMessage
Dim VariableBlockAddress
Dim NextValueAddress
With Sheets("VariableValues")
' Select the block of variable names and values starting at cell C4
VariableBlockAddress = .Range("B4").End(xlDown).Offset(0, 1).Address
.Activate
.Range("B4:" & VariableBlockAddress).Select
' Create Names for variable values, giving them the variable name
' Note that the variable block has to be SELECTED before the names
' can be created.
Selection.CreateNames Top:=False, Left:=True, Bottom:=False, Right:=False
.Range("B4").Select
End With
gbolUseDefaultValues = Range(Names("gbolUseDefaultValues")).Value
gstrSelectedList = Range(Names("gstrSelectedList")).Value
gbolDeleteOldList = Range(Names("gbolDeleteOldList")).Value
gstrFilter1 = Range(Names("gstrFilter1")).Value
gstrFilter2 = Range(Names("gstrFilter2")).Value
gstrFilter3 = Range(Names("gstrFilter3")).Value
gstrFilter4 = Range(Names("gstrFilter4")).Value
gstrFilePath = Range(Names("gstrFilePath")).Value
gstrNewListFilename = Range(Names("gstrNewListFilename")).Value
gstrPrevListFilename = Range(Names("gstrPrevListFilename")).Value
gintListColWidth = Range(Names("gintListColWidth")).Value
gintDataCleanColumnRelative = CInt(Range(Names("gintDataCleanColumnRelative")).Value)
gintDataCompareColumnRelative = CInt(Range(Names("gintDataCompareColumnRelative")).Value)
gintEmailBatchSize = CInt(Range(Names("gintEmailBatchSize")).Value)
gIntShowScreenInterval = Range(Names("gIntShowScreenInterval")).Value
gstrFilenameFormat = Range(Names("gstrFilenameFormat")).Value
gintMarkColumnNumberSelectRelative = CInt(Range(Names("gintMarkColumnNumberSelectRelative")).Value)
gintMarkColumnNumberNewRelative = CInt(Range(Names("gintMarkColumnNumberNewRelative")).Value)
gintTempColumnNumberRelative = CInt(Range(Names("gintTempColumnNumberRelative")).Value)
gintPasteColumnNumber = CInt(Range(Names("gintPasteColumnNumber")).Value)
gintAttachmentAdsColNumberRel = CInt(Range(Names("gintAttachmentAdsColNumberRel")).Value)
gMarkColourNew = Range(Names("gMarkColourNew")).Interior.ColorIndex
gMarkColourSelect = Range(Names("gMarkColourSelect")).Interior.ColorIndex
gMarkColourCopied = Range(Names("gMarkColourCopied")).Interior.ColorIndex
gMarkColourAfterEmail1 = Range(Names("gMarkColourAfterEmail1")).Interior.ColorIndex
gMarkColourBeforeEmail2 = Range(Names("gMarkColourBeforeEmail2")).Interior.ColorIndex
gMarkColourAfterEmail2 = Range(Names("gMarkColourAfterEmail2")).Interior.ColorIndex
gintEmail1Email2Delay = CInt(Range(Names("gintEmail1Email2Delay")).Value)
gstrColHeading(1) = Range(Names("gstrColHeading_1")).Value
gstrColHeading(2) = Range(Names("gstrColHeading_2")).Value
gstrColHeading(3) = Range(Names("gstrColHeading_3")).Value
gstrColHeading(4) = Range(Names("gstrColHeading_4")).Value
gstrColHeading(5) = Range(Names("gstrColHeading_5")).Value
gstrColHeading(6) = Range(Names("gstrColHeading_6")).Value
gstrColHeading(7) = Range(Names("gstrColHeading_7")).Value
gstrColHeading(8) = Range(Names("gstrColHeading_8")).Value
gstrColHeading(9) = Range(Names("gstrColHeading_9")).Value
gstrColHeading(10) = Range(Names("gstrColHeading_10")).Value
gstrColHeading(11) = Range(Names("gstrColHeading_11")).Value
gstrColHeading(12) = Range(Names("gstrColHeading_12")).Value
gstrColHeading(13) = Range(Names("gstrColHeading_13")).Value
gstrColHeading(14) = Range(Names("gstrColHeading_14")).Value
gstrEmail1HTMLBodyLine(1) = Range(Names("gstrEmail1HTMLBodyLine_1")).Value
gstrEmail1HTMLBodyLine(2) = Range(Names("gstrEmail1HTMLBodyLine_2")).Value
gstrEmail1HTMLBodyLine(3) = Range(Names("gstrEmail1HTMLBodyLine_3")).Value
gstrEmail1HTMLBodyLine(4) = Range(Names("gstrEmail1HTMLBodyLine_4")).Value
gstrEmail1HTMLBodyLine(5) = Range(Names("gstrEmail1HTMLBodyLine_5")).Value
gstrEmail1HTMLBodyLine(6) = Range(Names("gstrEmail1HTMLBodyLine_6")).Value
gstrEmail1HTMLBodyLine(7) = Range(Names("gstrEmail1HTMLBodyLine_7")).Value
gstrEmail1HTMLBodyLine(8) = Range(Names("gstrEmail1HTMLBodyLine_8")).Value
gstrEmail1HTMLBodyLine(9) = Range(Names("gstrEmail1HTMLBodyLine_9")).Value
gstrEmail1HTMLBodyLine(10) = Range(Names("gstrEmail1HTMLBodyLine_10")).Value
gstrEmail1HTMLBodyLine(11) = Range(Names("gstrEmail1HTMLBodyLine_11")).Value
gstrEmail1HTMLBodyLine(12) = Range(Names("gstrEmail1HTMLBodyLine_12")).Value
gstrEmail1HTMLBodyLine(13) = Range(Names("gstrEmail1HTMLBodyLine_13")).Value
gstrEmail1HTMLBodyLine(14) = Range(Names("gstrEmail1HTMLBodyLine_14")).Value
gstrEmail1HTMLBodyLine(15) = Range(Names("gstrEmail1HTMLBodyLine_15")).Value
gstrEmail1HTMLBodyLine(16) = Range(Names("gstrEmail1HTMLBodyLine_16")).Value
gstrEmail1HTMLBodyLine(17) = Range(Names("gstrEmail1HTMLBodyLine_17")).Value
gstrEmail1HTMLBodyLine(18) = Range(Names("gstrEmail1HTMLBodyLine_18")).Value
gstrEmail1HTMLBodyLine(19) = Range(Names("gstrEmail1HTMLBodyLine_19")).Value
gstrEmail1HTMLBodyLine(20) = Range(Names("gstrEmail1HTMLBodyLine_20")).Value
gstrEmail1HTMLBodyLine(21) = Range(Names("gstrEmail1HTMLBodyLine_21")).Value
gstrEmail1HTMLBodyLine(22) = Range(Names("gstrEmail1HTMLBodyLine_22")).Value
gstrEmail1HTMLBodyLine(23) = Range(Names("gstrEmail1HTMLBodyLine_23")).Value
gstrEmail1HTMLBodyLine(24) = Range(Names("gstrEmail1HTMLBodyLine_24")).Value
gstrEmail1HTMLBodyLine(25) = Range(Names("gstrEmail1HTMLBodyLine_25")).Value
gstrEmail1HTMLBodyLine(26) = Range(Names("gstrEmail1HTMLBodyLine_26")).Value
gstrEmail1HTMLBodyLine(27) = Range(Names("gstrEmail1HTMLBodyLine_27")).Value
gstrEmail1HTMLBodyLine(28) = Range(Names("gstrEmail1HTMLBodyLine_28")).Value
gstrEmail1HTMLBodyLine(29) = Range(Names("gstrEmail1HTMLBodyLine_29")).Value
gstrEmail1HTMLBodyLine(30) = Range(Names("gstrEmail1HTMLBodyLine_30")).Value
gstrEmail1HTMLBodyLine(31) = Range(Names("gstrEmail1HTMLBodyLine_31")).Value
gstrEmail1HTMLBodyLine(32) = Range(Names("gstrEmail1HTMLBodyLine_32")).Value
gstrEmail1HTMLBodyLine(33) = Range(Names("gstrEmail1HTMLBodyLine_33")).Value
gstrEmail1HTMLBodyLine(34) = Range(Names("gstrEmail1HTMLBodyLine_34")).Value
gstrEmail1HTMLBodyLine(35) = Range(Names("gstrEmail1HTMLBodyLine_35")).Value
gstrEmail1HTMLBodyLine(36) = Range(Names("gstrEmail1HTMLBodyLine_36")).Value
gstrEmail1HTMLBodyLine(37) = Range(Names("gstrEmail1HTMLBodyLine_37")).Value
gstrEmail1HTMLBodyLine(38) = Range(Names("gstrEmail1HTMLBodyLine_38")).Value
gstrEmail1HTMLBodyLine(39) = Range(Names("gstrEmail1HTMLBodyLine_39")).Value
gstrEmail1HTMLBodyLine(40) = Range(Names("gstrEmail1HTMLBodyLine_40")).Value
gstrEmail1HTMLBodyLine(41) = Range(Names("gstrEmail1HTMLBodyLine_41")).Value
gstrEmail1HTMLBodyLine(42) = Range(Names("gstrEmail1HTMLBodyLine_42")).Value
gstrEmail1HTMLBodyLine(43) = Range(Names("gstrEmail1HTMLBodyLine_43")).Value
gstrEmail1HTMLBodyLine(44) = Range(Names("gstrEmail1HTMLBodyLine_44")).Value
gstrEmail1HTMLBodyLine(45) = Range(Names("gstrEmail1HTMLBodyLine_45")).Value
gstrEmail1HTMLBodyLine(46) = Range(Names("gstrEmail1HTMLBodyLine_46")).Value
gstrEmail1HTMLBodyLine(47) = Range(Names("gstrEmail1HTMLBodyLine_47")).Value
gstrEmail1HTMLBodyLine(48) = Range(Names("gstrEmail1HTMLBodyLine_48")).Value
gstrEmail1HTMLBodyLine(49) = Range(Names("gstrEmail1HTMLBodyLine_49")).Value
gstrEmail1HTMLBodyLine(50) = Range(Names("gstrEmail1HTMLBodyLine_50")).Value
gstrAttachment.ID(1) = Range(Names("gstrAttachment_ID_1")).Value
gstrAttachment.ID(2) = Range(Names("gstrAttachment_ID_2")).Value
gstrAttachment.ID(3) = Range(Names("gstrAttachment_ID_3")).Value
gstrAttachment.ID(4) = Range(Names("gstrAttachment_ID_4")).Value
gstrAttachment.ID(5) = Range(Names("gstrAttachment_ID_5")).Value
gstrAttachment.ID(6) = Range(Names("gstrAttachment_ID_6")).Value
gstrAttachment.ID(7) = Range(Names("gstrAttachment_ID_7")).Value
gstrAttachment.ID(8) = Range(Names("gstrAttachment_ID_8")).Value
gstrAttachment.ID(9) = Range(Names("gstrAttachment_ID_9")).Value
gstrAttachment.ID(10) = Range(Names("gstrAttachment_ID_10")).Value
gstrAttachment.FilePath(1) = Range(Names("gstrAttachment_FilePath_1")).Value
gstrAttachment.FilePath(2) = Range(Names("gstrAttachment_FilePath_2")).Value
gstrAttachment.FilePath(3) = Range(Names("gstrAttachment_FilePath_3")).Value
gstrAttachment.FilePath(4) = Range(Names("gstrAttachment_FilePath_4")).Value
gstrAttachment.FilePath(5) = Range(Names("gstrAttachment_FilePath_5")).Value
gstrAttachment.FilePath(6) = Range(Names("gstrAttachment_FilePath_6")).Value
gstrAttachment.FilePath(7) = Range(Names("gstrAttachment_FilePath_7")).Value
gstrAttachment.FilePath(8) = Range(Names("gstrAttachment_FilePath_8")).Value
gstrAttachment.FilePath(9) = Range(Names("gstrAttachment_FilePath_9")).Value
gstrAttachment.FilePath(10) = Range(Names("gstrAttachment_FilePath_10")).Value
gstrEmail2HTMLBodyLine(1) = Range(Names("gstrEmail2HTMLBodyLine_1")).Value
gstrEmail2HTMLBodyLine(2) = Range(Names("gstrEmail2HTMLBodyLine_2")).Value
gstrEmail2HTMLBodyLine(3) = Range(Names("gstrEmail2HTMLBodyLine_3")).Value
gstrEmail2HTMLBodyLine(4) = Range(Names("gstrEmail2HTMLBodyLine_4")).Value
gstrEmail2HTMLBodyLine(5) = Range(Names("gstrEmail2HTMLBodyLine_5")).Value
gstrEmail2HTMLBodyLine(6) = Range(Names("gstrEmail2HTMLBodyLine_6")).Value
gstrEmail2HTMLBodyLine(7) = Range(Names("gstrEmail2HTMLBodyLine_7")).Value
gstrEmail2HTMLBodyLine(8) = Range(Names("gstrEmail2HTMLBodyLine_8")).Value
gstrEmail2HTMLBodyLine(9) = Range(Names("gstrEmail2HTMLBodyLine_9")).Value
gstrEmail2HTMLBodyLine(10) = Range(Names("gstrEmail2HTMLBodyLine_10")).Value
gstrEmail2HTMLBodyLine(11) = Range(Names("gstrEmail2HTMLBodyLine_11")).Value
gstrEmail2HTMLBodyLine(12) = Range(Names("gstrEmail2HTMLBodyLine_12")).Value
gstrEmail2HTMLBodyLine(13) = Range(Names("gstrEmail2HTMLBodyLine_13")).Value
gstrEmail2HTMLBodyLine(14) = Range(Names("gstrEmail2HTMLBodyLine_14")).Value
gstrEmail2HTMLBodyLine(15) = Range(Names("gstrEmail2HTMLBodyLine_15")).Value
gstrEmail2HTMLBodyLine(16) = Range(Names("gstrEmail2HTMLBodyLine_16")).Value
gstrEmail2HTMLBodyLine(17) = Range(Names("gstrEmail2HTMLBodyLine_17")).Value
gstrEmail2HTMLBodyLine(18) = Range(Names("gstrEmail2HTMLBodyLine_18")).Value
gstrEmail2HTMLBodyLine(19) = Range(Names("gstrEmail2HTMLBodyLine_19")).Value
gstrEmail2HTMLBodyLine(20) = Range(Names("gstrEmail2HTMLBodyLine_20")).Value
gstrEmail2HTMLBodyLine(21) = Range(Names("gstrEmail2HTMLBodyLine_21")).Value
gstrEmail2HTMLBodyLine(22) = Range(Names("gstrEmail2HTMLBodyLine_22")).Value
gstrEmail2HTMLBodyLine(23) = Range(Names("gstrEmail2HTMLBodyLine_23")).Value
gstrEmail2HTMLBodyLine(24) = Range(Names("gstrEmail2HTMLBodyLine_24")).Value
gstrEmail2HTMLBodyLine(25) = Range(Names("gstrEmail2HTMLBodyLine_25")).Value
gstrEmail2HTMLBodyLine(26) = Range(Names("gstrEmail2HTMLBodyLine_26")).Value
gstrEmail2HTMLBodyLine(27) = Range(Names("gstrEmail2HTMLBodyLine_27")).Value
gstrEmail2HTMLBodyLine(28) = Range(Names("gstrEmail2HTMLBodyLine_28")).Value
gstrEmail2HTMLBodyLine(29) = Range(Names("gstrEmail2HTMLBodyLine_29")).Value
gstrEmail2HTMLBodyLine(30) = Range(Names("gstrEmail2HTMLBodyLine_30")).Value
gstrEmail2HTMLBodyLine(31) = Range(Names("gstrEmail2HTMLBodyLine_31")).Value
gstrEmail2HTMLBodyLine(32) = Range(Names("gstrEmail2HTMLBodyLine_32")).Value
gstrEmail2HTMLBodyLine(33) = Range(Names("gstrEmail2HTMLBodyLine_33")).Value
' Special Casses of variable values
' gstrNewListFilename = "Sales" & Format(Format(Date - 1, "yymmdd"), "000000") & ".csv"
' gstrPrevListFilename = "Sales" & Format(Format(Date - 2, "yymmdd"), "000000") & ".csv"
Range("B4").Select
End Sub
SetDefaultValues
' Set User Values from cells adjacent to the default values.
If CStr(Range(Names("gstrSelectedList")).Offset(0, 1).Value) <> "" Then _
gstrSelectedList = Range(Names("gstrSelectedList")).Offset(0, 1).Value
If CStr(Range(Names("gbolDeleteOldList")).Offset(0, 1).Value) <> "" Then _
gbolDeleteOldList = CBool(Range(Names("gbolDeleteOldList")).Offset(0, 1).Value)
If CStr(Range(Names("gstrFilter1")).Offset(0, 1).Value) <> "" Then _
gstrFilter1 = Range(Names("gstrFilter1")).Offset(0, 1).Value
If CStr(Range(Names("gstrFilter2")).Offset(0, 1).Value) <> "" Then _
gstrFilter2 = Range(Names("gstrFilter2")).Offset(0, 1).Value
If CStr(Range(Names("gstrFilter3")).Offset(0, 1).Value) <> "" Then _
gstrFilter3 = Range(Names("gstrFilter3")).Offset(0, 1).Value
If CStr(Range(Names("gstrFilter4")).Offset(0, 1).Value) <> "" Then _
gstrFilter4 = Range(Names("gstrFilter4")).Offset(0, 1).Value
If CStr(Range(Names("gstrFilePath")).Offset(0, 1).Value) <> "" Then _
gstrFilePath = Range(Names("gstrFilePath")).Offset(0, 1).Value
If CStr(Range(Names("gstrNewListFilename")).Offset(0, 1).Value) <> "" Then _
gstrNewListFilename = Range(Names("gstrNewListFilename")).Offset(0, 1).Value
If CStr(Range(Names("gstrPrevListFilename")).Offset(0, 1).Value) <> "" Then _
gstrPrevListFilename = Range(Names("gstrPrevListFilename")).Offset(0, 1).Value
If CStr(Range(Names("gintListColWidth")).Offset(0, 1).Value) <> "" Then _
gintListColWidth = CInt(Range(Names("gintListColWidth")).Offset(0, 1).Value)
If CStr(Range(Names("gintDataCleanColumnRelative")).Offset(0, 1).Value) <> "" Then _
gintDataCleanColumnRelative = Range(Names("gintDataCleanColumnRelative")).Offset(0, 1).Value
If CStr(Range(Names("gintDataCompareColumnRelative")).Offset(0, 1).Value) <> "" Then _
gintDataCompareColumnRelative = Range(Names("gintDataCompareColumnRelative")).Offset(0, 1).Value
If CStr(Range(Names("gintEmailBatchSize")).Offset(0, 1).Value) <> "" Then _
gintEmailBatchSize = Range(Names("gintEmailBatchSize")).Offset(0, 1).Value
If CStr(Range(Names("gIntShowScreenInterval")).Offset(0, 1).Value) <> "" Then _
gIntShowScreenInterval = Range(Names("gIntShowScreenInterval")).Offset(0, 1).Value
If CStr(Range(Names("gstrFilenameFormat")).Offset(0, 1).Value) <> "" Then _
gstrFilenameFormat = Range(Names("gstrFilenameFormat")).Offset(0, 1).Value
If CStr(Range(Names("gintMarkColumnNumberSelectRelative")).Offset(0, 1).Value) <> "" Then _
gintMarkColumnNumberSelectRelative = CInt(Range(Names("gintMarkColumnNumberSelectRelative")).Offset(0, 1).Value)
If CStr(Range(Names("gintMarkColumnNumberNewRelative")).Offset(0, 1).Value) <> "" Then _
gintMarkColumnNumberNewRelative = CInt(Range(Names("gintMarkColumnNumberNewRelative")).Offset(0, 1).Value)
If CStr(Range(Names("gintTempColumnNumberRelative")).Offset(0, 1).Value) <> "" Then _
gintTempColumnNumberRelative = CInt(Range(Names("gintTempColumnNumberRelative")).Offset(0, 1).Value)
If CStr(Range(Names("gintPasteColumnNumber")).Offset(0, 1).Value) <> "" Then _
gintPasteColumnNumber = CInt(Range(Names("gintPasteColumnNumber")).Offset(0, 1).Value)
If CStr(Range(Names("gintAttachmentAdsColNumberRel")).Offset(0, 1).Value) <> "" Then _
gintAttachmentAdsColNumberRel = CInt(Range(Names("gintAttachmentAdsColNumberRel")).Offset(0, 1).Value)
' For the colour indeces, check the the user's selected colour <>
' colour of the cell containing the variable name (Windows background colour).
If Range(Names("gMarkColourNew")).Offset(0, 1).Interior.ColorIndex <> _
Range(Names("gMarkColourNew")).Offset(0, -1).Interior.ColorIndex Then _
gMarkColourNew = Range(Names("gMarkColourNew")).Offset(0, 1).Interior.ColorIndex
If Range(Names("gMarkColourSelect")).Offset(0, 1).Interior.ColorIndex <> _
Range(Names("gMarkColourSelect")).Offset(0, -1).Interior.ColorIndex Then _
gMarkColourSelect = Range(Names("gMarkColourSelect")).Offset(0, 1).Interior.ColorIndex
If Range(Names("gMarkColourCopied")).Offset(0, 1).Interior.ColorIndex <> _
Range(Names("gMarkColourCopied")).Offset(0, -1).Interior.ColorIndex Then _
gMarkColourCopied = Range(Names("gMarkColourCopied")).Offset(0, 1).Interior.ColorIndex
If Range(Names("gMarkColourAfterEmail1")).Offset(0, 1).Interior.ColorIndex <> _
Range(Names("gMarkColourAfterEmail1")).Offset(0, -1).Interior.ColorIndex Then _
gMarkColourAfterEmail1 = Range(Names("gMarkColourAfterEmail1")).Offset(0, 1).Interior.ColorIndex
If Range(Names("gMarkColourBeforeEmail2")).Offset(0, 1).Interior.ColorIndex <> _
Range(Names("gMarkColourBeforeEmail2")).Offset(0, -1).Interior.ColorIndex Then _
gMarkColourBeforeEmail2 = Range(Names("gMarkColourBeforeEmail2")).Offset(0, 1).Interior.ColorIndex
If Range(Names("gMarkColourAfterEmail2")).Offset(0, 1).Interior.ColorIndex <> _
Range(Names("gMarkColourAfterEmail2")).Offset(0, -1).Interior.ColorIndex Then _
gMarkColourAfterEmail2 = Range(Names("gMarkColourAfterEmail2")).Offset(0, 1).Interior.ColorIndex
If CStr(Range(Names("gintEmail1Email2Delay")).Offset(0, 1).Value) <> "" Then _
gintEmail1Email2Delay = Range(Names("gintEmail1Email2Delay")).Offset(0, 1).Value
If CStr(Range(Names("gstrColHeading_1")).Offset(0, 1).Value) <> "" Then gstrColHeading(1) = Range(Names("gstrColHeading_1")).Offset(0, 1).Value
If CStr(Range(Names("gstrColHeading_2")).Offset(0, 1).Value) <> "" Then gstrColHeading(2) = Range(Names("gstrColHeading_2")).Offset(0, 1).Value
If CStr(Range(Names("gstrColHeading_3")).Offset(0, 1).Value) <> "" Then gstrColHeading(3) = Range(Names("gstrColHeading_3")).Offset(0, 1).Value
If CStr(Range(Names("gstrColHeading_4")).Offset(0, 1).Value) <> "" Then gstrColHeading(4) = Range(Names("gstrColHeading_4")).Offset(0, 1).Value
If CStr(Range(Names("gstrColHeading_5")).Offset(0, 1).Value) <> "" Then gstrColHeading(5) = Range(Names("gstrColHeading_5")).Offset(0, 1).Value
If CStr(Range(Names("gstrColHeading_6")).Offset(0, 1).Value) <> "" Then gstrColHeading(6) = Range(Names("gstrColHeading_6")).Offset(0, 1).Value
If CStr(Range(Names("gstrColHeading_7")).Offset(0, 1).Value) <> "" Then gstrColHeading(7) = Range(Names("gstrColHeading_7")).Offset(0, 1).Value
If CStr(Range(Names("gstrColHeading_8")).Offset(0, 1).Value) <> "" Then gstrColHeading(8) = Range(Names("gstrColHeading_8")).Offset(0, 1).Value
If CStr(Range(Names("gstrColHeading_9")).Offset(0, 1).Value) <> "" Then gstrColHeading(9) = Range(Names("gstrColHeading_9")).Offset(0, 1).Value
If CStr(Range(Names("gstrColHeading_10")).Offset(0, 1).Value) <> "" Then gstrColHeading(10) = Range(Names("gstrColHeading_10")).Offset(0, 1).Value
If CStr(Range(Names("gstrColHeading_11")).Offset(0, 1).Value) <> "" Then gstrColHeading(11) = Range(Names("gstrColHeading_11")).Offset(0, 1).Value
If CStr(Range(Names("gstrColHeading_12")).Offset(0, 1).Value) <> "" Then gstrColHeading(12) = Range(Names("gstrColHeading_12")).Offset(0, 1).Value
If CStr(Range(Names("gstrColHeading_13")).Offset(0, 1).Value) <> "" Then gstrColHeading(13) = Range(Names("gstrColHeading_13")).Offset(0, 1).Value
If CStr(Range(Names("gstrColHeading_14")).Offset(0, 1).Value) <> "" Then gstrColHeading(14) = Range(Names("gstrColHeading_14")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail1HTMLBodyLine_1")).Offset(0, 1).Value) <> "" Then gstrEmail1HTMLBodyLine(1) = Range(Names("gstrEmail1HTMLBodyLine_1")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail1HTMLBodyLine_2")).Offset(0, 1).Value) <> "" Then gstrEmail1HTMLBodyLine(2) = Range(Names("gstrEmail1HTMLBodyLine_2")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail1HTMLBodyLine_3")).Offset(0, 1).Value) <> "" Then gstrEmail1HTMLBodyLine(3) = Range(Names("gstrEmail1HTMLBodyLine_3")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail1HTMLBodyLine_4")).Offset(0, 1).Value) <> "" Then gstrEmail1HTMLBodyLine(4) = Range(Names("gstrEmail1HTMLBodyLine_4")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail1HTMLBodyLine_5")).Offset(0, 1).Value) <> "" Then gstrEmail1HTMLBodyLine(5) = Range(Names("gstrEmail1HTMLBodyLine_5")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail1HTMLBodyLine_6")).Offset(0, 1).Value) <> "" Then gstrEmail1HTMLBodyLine(6) = Range(Names("gstrEmail1HTMLBodyLine_6")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail1HTMLBodyLine_7")).Offset(0, 1).Value) <> "" Then gstrEmail1HTMLBodyLine(7) = Range(Names("gstrEmail1HTMLBodyLine_7")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail1HTMLBodyLine_8")).Offset(0, 1).Value) <> "" Then gstrEmail1HTMLBodyLine(8) = Range(Names("gstrEmail1HTMLBodyLine_8")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail1HTMLBodyLine_9")).Offset(0, 1).Value) <> "" Then gstrEmail1HTMLBodyLine(9) = Range(Names("gstrEmail1HTMLBodyLine_9")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail1HTMLBodyLine_10")).Offset(0, 1).Value) <> "" Then gstrEmail1HTMLBodyLine(10) = Range(Names("gstrEmail1HTMLBodyLine_10")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail1HTMLBodyLine_11")).Offset(0, 1).Value) <> "" Then gstrEmail1HTMLBodyLine(11) = Range(Names("gstrEmail1HTMLBodyLine_11")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail1HTMLBodyLine_12")).Offset(0, 1).Value) <> "" Then gstrEmail1HTMLBodyLine(12) = Range(Names("gstrEmail1HTMLBodyLine_12")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail1HTMLBodyLine_13")).Offset(0, 1).Value) <> "" Then gstrEmail1HTMLBodyLine(13) = Range(Names("gstrEmail1HTMLBodyLine_13")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail1HTMLBodyLine_14")).Offset(0, 1).Value) <> "" Then gstrEmail1HTMLBodyLine(14) = Range(Names("gstrEmail1HTMLBodyLine_14")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail1HTMLBodyLine_15")).Offset(0, 1).Value) <> "" Then gstrEmail1HTMLBodyLine(15) = Range(Names("gstrEmail1HTMLBodyLine_15")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail1HTMLBodyLine_16")).Offset(0, 1).Value) <> "" Then gstrEmail1HTMLBodyLine(16) = Range(Names("gstrEmail1HTMLBodyLine_16")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail1HTMLBodyLine_17")).Offset(0, 1).Value) <> "" Then gstrEmail1HTMLBodyLine(17) = Range(Names("gstrEmail1HTMLBodyLine_17")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail1HTMLBodyLine_18")).Offset(0, 1).Value) <> "" Then gstrEmail1HTMLBodyLine(18) = Range(Names("gstrEmail1HTMLBodyLine_18")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail1HTMLBodyLine_19")).Offset(0, 1).Value) <> "" Then gstrEmail1HTMLBodyLine(19) = Range(Names("gstrEmail1HTMLBodyLine_19")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail1HTMLBodyLine_20")).Offset(0, 1).Value) <> "" Then gstrEmail1HTMLBodyLine(20) = Range(Names("gstrEmail1HTMLBodyLine_20")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail1HTMLBodyLine_21")).Offset(0, 1).Value) <> "" Then gstrEmail1HTMLBodyLine(21) = Range(Names("gstrEmail1HTMLBodyLine_21")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail1HTMLBodyLine_22")).Offset(0, 1).Value) <> "" Then gstrEmail1HTMLBodyLine(22) = Range(Names("gstrEmail1HTMLBodyLine_22")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail1HTMLBodyLine_23")).Offset(0, 1).Value) <> "" Then gstrEmail1HTMLBodyLine(23) = Range(Names("gstrEmail1HTMLBodyLine_23")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail1HTMLBodyLine_24")).Offset(0, 1).Value) <> "" Then gstrEmail1HTMLBodyLine(24) = Range(Names("gstrEmail1HTMLBodyLine_24")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail1HTMLBodyLine_25")).Offset(0, 1).Value) <> "" Then gstrEmail1HTMLBodyLine(25) = Range(Names("gstrEmail1HTMLBodyLine_25")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail1HTMLBodyLine_26")).Offset(0, 1).Value) <> "" Then gstrEmail1HTMLBodyLine(26) = Range(Names("gstrEmail1HTMLBodyLine_26")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail1HTMLBodyLine_27")).Offset(0, 1).Value) <> "" Then gstrEmail1HTMLBodyLine(27) = Range(Names("gstrEmail1HTMLBodyLine_27")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail1HTMLBodyLine_28")).Offset(0, 1).Value) <> "" Then gstrEmail1HTMLBodyLine(28) = Range(Names("gstrEmail1HTMLBodyLine_28")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail1HTMLBodyLine_29")).Offset(0, 1).Value) <> "" Then gstrEmail1HTMLBodyLine(29) = Range(Names("gstrEmail1HTMLBodyLine_29")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail1HTMLBodyLine_30")).Offset(0, 1).Value) <> "" Then gstrEmail1HTMLBodyLine(30) = Range(Names("gstrEmail1HTMLBodyLine_30")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail1HTMLBodyLine_31")).Offset(0, 1).Value) <> "" Then gstrEmail1HTMLBodyLine(31) = Range(Names("gstrEmail1HTMLBodyLine_31")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail1HTMLBodyLine_32")).Offset(0, 1).Value) <> "" Then gstrEmail1HTMLBodyLine(32) = Range(Names("gstrEmail1HTMLBodyLine_32")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail1HTMLBodyLine_33")).Offset(0, 1).Value) <> "" Then gstrEmail1HTMLBodyLine(33) = Range(Names("gstrEmail1HTMLBodyLine_33")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail1HTMLBodyLine_34")).Offset(0, 1).Value) <> "" Then gstrEmail1HTMLBodyLine(34) = Range(Names("gstrEmail1HTMLBodyLine_34")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail1HTMLBodyLine_35")).Offset(0, 1).Value) <> "" Then gstrEmail1HTMLBodyLine(35) = Range(Names("gstrEmail1HTMLBodyLine_35")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail1HTMLBodyLine_36")).Offset(0, 1).Value) <> "" Then gstrEmail1HTMLBodyLine(36) = Range(Names("gstrEmail1HTMLBodyLine_36")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail1HTMLBodyLine_37")).Offset(0, 1).Value) <> "" Then gstrEmail1HTMLBodyLine(37) = Range(Names("gstrEmail1HTMLBodyLine_37")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail1HTMLBodyLine_38")).Offset(0, 1).Value) <> "" Then gstrEmail1HTMLBodyLine(38) = Range(Names("gstrEmail1HTMLBodyLine_38")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail1HTMLBodyLine_39")).Offset(0, 1).Value) <> "" Then gstrEmail1HTMLBodyLine(39) = Range(Names("gstrEmail1HTMLBodyLine_39")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail1HTMLBodyLine_40")).Offset(0, 1).Value) <> "" Then gstrEmail1HTMLBodyLine(40) = Range(Names("gstrEmail1HTMLBodyLine_40")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail1HTMLBodyLine_41")).Offset(0, 1).Value) <> "" Then gstrEmail1HTMLBodyLine(41) = Range(Names("gstrEmail1HTMLBodyLine_41")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail1HTMLBodyLine_42")).Offset(0, 1).Value) <> "" Then gstrEmail1HTMLBodyLine(42) = Range(Names("gstrEmail1HTMLBodyLine_42")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail1HTMLBodyLine_43")).Offset(0, 1).Value) <> "" Then gstrEmail1HTMLBodyLine(43) = Range(Names("gstrEmail1HTMLBodyLine_43")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail1HTMLBodyLine_44")).Offset(0, 1).Value) <> "" Then gstrEmail1HTMLBodyLine(44) = Range(Names("gstrEmail1HTMLBodyLine_44")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail1HTMLBodyLine_45")).Offset(0, 1).Value) <> "" Then gstrEmail1HTMLBodyLine(45) = Range(Names("gstrEmail1HTMLBodyLine_45")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail1HTMLBodyLine_46")).Offset(0, 1).Value) <> "" Then gstrEmail1HTMLBodyLine(46) = Range(Names("gstrEmail1HTMLBodyLine_46")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail1HTMLBodyLine_47")).Offset(0, 1).Value) <> "" Then gstrEmail1HTMLBodyLine(47) = Range(Names("gstrEmail1HTMLBodyLine_47")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail1HTMLBodyLine_48")).Offset(0, 1).Value) <> "" Then gstrEmail1HTMLBodyLine(48) = Range(Names("gstrEmail1HTMLBodyLine_48")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail1HTMLBodyLine_49")).Offset(0, 1).Value) <> "" Then gstrEmail1HTMLBodyLine(49) = Range(Names("gstrEmail1HTMLBodyLine_49")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail1HTMLBodyLine_50")).Offset(0, 1).Value) <> "" Then gstrEmail1HTMLBodyLine(50) = Range(Names("gstrEmail1HTMLBodyLine_50")).Offset(0, 1).Value
If CStr(Range(Names("gstrAttachment_ID_1")).Offset(0, 1).Value) <> "" Then gstrAttachment.ID(1) = Range(Names("gstrAttachment_ID_1")).Offset(0, 1).Value
If CStr(Range(Names("gstrAttachment_ID_2")).Offset(0, 1).Value) <> "" Then gstrAttachment.ID(2) = Range(Names("gstrAttachment_ID_2")).Offset(0, 1).Value
If CStr(Range(Names("gstrAttachment_ID_3")).Offset(0, 1).Value) <> "" Then gstrAttachment.ID(3) = Range(Names("gstrAttachment_ID_3")).Offset(0, 1).Value
If CStr(Range(Names("gstrAttachment_ID_4")).Offset(0, 1).Value) <> "" Then gstrAttachment.ID(4) = Range(Names("gstrAttachment_ID_4")).Offset(0, 1).Value
If CStr(Range(Names("gstrAttachment_ID_5")).Offset(0, 1).Value) <> "" Then gstrAttachment.ID(5) = Range(Names("gstrAttachment_ID_5")).Offset(0, 1).Value
If CStr(Range(Names("gstrAttachment_ID_6")).Offset(0, 1).Value) <> "" Then gstrAttachment.ID(6) = Range(Names("gstrAttachment_ID_6")).Offset(0, 1).Value
If CStr(Range(Names("gstrAttachment_ID_7")).Offset(0, 1).Value) <> "" Then gstrAttachment.ID(7) = Range(Names("gstrAttachment_ID_7")).Offset(0, 1).Value
If CStr(Range(Names("gstrAttachment_ID_8")).Offset(0, 1).Value) <> "" Then gstrAttachment.ID(8) = Range(Names("gstrAttachment_ID_8")).Offset(0, 1).Value
If CStr(Range(Names("gstrAttachment_ID_9")).Offset(0, 1).Value) <> "" Then gstrAttachment.ID(9) = Range(Names("gstrAttachment_ID_9")).Offset(0, 1).Value
If CStr(Range(Names("gstrAttachment_ID_10")).Offset(0, 1).Value) <> "" Then gstrAttachment.ID(10) = Range(Names("gstrAttachment_ID_10")).Offset(0, 1).Value
If CStr(Range(Names("gstrAttachment_FilePath_1")).Offset(0, 1).Value) <> "" Then gstrAttachment.FilePath(1) = Range(Names("gstrAttachment_FilePath_1")).Offset(0, 1).Value
If CStr(Range(Names("gstrAttachment_FilePath_2")).Offset(0, 1).Value) <> "" Then gstrAttachment.FilePath(2) = Range(Names("gstrAttachment_FilePath_2")).Offset(0, 1).Value
If CStr(Range(Names("gstrAttachment_FilePath_3")).Offset(0, 1).Value) <> "" Then gstrAttachment.FilePath(3) = Range(Names("gstrAttachment_FilePath_3")).Offset(0, 1).Value
If CStr(Range(Names("gstrAttachment_FilePath_4")).Offset(0, 1).Value) <> "" Then gstrAttachment.FilePath(4) = Range(Names("gstrAttachment_FilePath_4")).Offset(0, 1).Value
If CStr(Range(Names("gstrAttachment_FilePath_5")).Offset(0, 1).Value) <> "" Then gstrAttachment.FilePath(5) = Range(Names("gstrAttachment_FilePath_5")).Offset(0, 1).Value
If CStr(Range(Names("gstrAttachment_FilePath_6")).Offset(0, 1).Value) <> "" Then gstrAttachment.FilePath(6) = Range(Names("gstrAttachment_FilePath_6")).Offset(0, 1).Value
If CStr(Range(Names("gstrAttachment_FilePath_7")).Offset(0, 1).Value) <> "" Then gstrAttachment.FilePath(7) = Range(Names("gstrAttachment_FilePath_7")).Offset(0, 1).Value
If CStr(Range(Names("gstrAttachment_FilePath_8")).Offset(0, 1).Value) <> "" Then gstrAttachment.FilePath(8) = Range(Names("gstrAttachment_FilePath_8")).Offset(0, 1).Value
If CStr(Range(Names("gstrAttachment_FilePath_9")).Offset(0, 1).Value) <> "" Then gstrAttachment.FilePath(9) = Range(Names("gstrAttachment_FilePath_9")).Offset(0, 1).Value
If CStr(Range(Names("gstrAttachment_FilePath_10")).Offset(0, 1).Value) <> "" Then gstrAttachment.FilePath(10) = Range(Names("gstrAttachment_FilePath_10")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail2HTMLBodyLine_1")).Offset(0, 1).Value) <> "" Then gstrEmail2HTMLBodyLine(1) = Range(Names("gstrEmail2HTMLBodyLine_1")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail2HTMLBodyLine_2")).Offset(0, 1).Value) <> "" Then gstrEmail2HTMLBodyLine(2) = Range(Names("gstrEmail2HTMLBodyLine_2")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail2HTMLBodyLine_3")).Offset(0, 1).Value) <> "" Then gstrEmail2HTMLBodyLine(3) = Range(Names("gstrEmail2HTMLBodyLine_3")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail2HTMLBodyLine_4")).Offset(0, 1).Value) <> "" Then gstrEmail2HTMLBodyLine(4) = Range(Names("gstrEmail2HTMLBodyLine_4")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail2HTMLBodyLine_5")).Offset(0, 1).Value) <> "" Then gstrEmail2HTMLBodyLine(5) = Range(Names("gstrEmail2HTMLBodyLine_5")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail2HTMLBodyLine_6")).Offset(0, 1).Value) <> "" Then gstrEmail2HTMLBodyLine(6) = Range(Names("gstrEmail2HTMLBodyLine_6")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail2HTMLBodyLine_7")).Offset(0, 1).Value) <> "" Then gstrEmail2HTMLBodyLine(7) = Range(Names("gstrEmail2HTMLBodyLine_7")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail2HTMLBodyLine_8")).Offset(0, 1).Value) <> "" Then gstrEmail2HTMLBodyLine(8) = Range(Names("gstrEmail2HTMLBodyLine_8")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail2HTMLBodyLine_9")).Offset(0, 1).Value) <> "" Then gstrEmail2HTMLBodyLine(9) = Range(Names("gstrEmail2HTMLBodyLine_9")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail2HTMLBodyLine_10")).Offset(0, 1).Value) <> "" Then gstrEmail2HTMLBodyLine(10) = Range(Names("gstrEmail2HTMLBodyLine_10")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail2HTMLBodyLine_11")).Offset(0, 1).Value) <> "" Then gstrEmail2HTMLBodyLine(11) = Range(Names("gstrEmail2HTMLBodyLine_11")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail2HTMLBodyLine_12")).Offset(0, 1).Value) <> "" Then gstrEmail2HTMLBodyLine(12) = Range(Names("gstrEmail2HTMLBodyLine_12")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail2HTMLBodyLine_13")).Offset(0, 1).Value) <> "" Then gstrEmail2HTMLBodyLine(13) = Range(Names("gstrEmail2HTMLBodyLine_13")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail2HTMLBodyLine_14")).Offset(0, 1).Value) <> "" Then gstrEmail2HTMLBodyLine(14) = Range(Names("gstrEmail2HTMLBodyLine_14")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail2HTMLBodyLine_15")).Offset(0, 1).Value) <> "" Then gstrEmail2HTMLBodyLine(15) = Range(Names("gstrEmail2HTMLBodyLine_15")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail2HTMLBodyLine_16")).Offset(0, 1).Value) <> "" Then gstrEmail2HTMLBodyLine(16) = Range(Names("gstrEmail2HTMLBodyLine_16")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail2HTMLBodyLine_17")).Offset(0, 1).Value) <> "" Then gstrEmail2HTMLBodyLine(17) = Range(Names("gstrEmail2HTMLBodyLine_17")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail2HTMLBodyLine_18")).Offset(0, 1).Value) <> "" Then gstrEmail2HTMLBodyLine(18) = Range(Names("gstrEmail2HTMLBodyLine_18")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail2HTMLBodyLine_19")).Offset(0, 1).Value) <> "" Then gstrEmail2HTMLBodyLine(19) = Range(Names("gstrEmail2HTMLBodyLine_19")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail2HTMLBodyLine_20")).Offset(0, 1).Value) <> "" Then gstrEmail2HTMLBodyLine(20) = Range(Names("gstrEmail2HTMLBodyLine_20")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail2HTMLBodyLine_21")).Offset(0, 1).Value) <> "" Then gstrEmail2HTMLBodyLine(21) = Range(Names("gstrEmail2HTMLBodyLine_21")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail2HTMLBodyLine_22")).Offset(0, 1).Value) <> "" Then gstrEmail2HTMLBodyLine(22) = Range(Names("gstrEmail2HTMLBodyLine_22")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail2HTMLBodyLine_23")).Offset(0, 1).Value) <> "" Then gstrEmail2HTMLBodyLine(23) = Range(Names("gstrEmail2HTMLBodyLine_23")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail2HTMLBodyLine_24")).Offset(0, 1).Value) <> "" Then gstrEmail2HTMLBodyLine(24) = Range(Names("gstrEmail2HTMLBodyLine_24")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail2HTMLBodyLine_25")).Offset(0, 1).Value) <> "" Then gstrEmail2HTMLBodyLine(25) = Range(Names("gstrEmail2HTMLBodyLine_25")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail2HTMLBodyLine_26")).Offset(0, 1).Value) <> "" Then gstrEmail2HTMLBodyLine(26) = Range(Names("gstrEmail2HTMLBodyLine_26")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail2HTMLBodyLine_27")).Offset(0, 1).Value) <> "" Then gstrEmail2HTMLBodyLine(27) = Range(Names("gstrEmail2HTMLBodyLine_27")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail2HTMLBodyLine_28")).Offset(0, 1).Value) <> "" Then gstrEmail2HTMLBodyLine(28) = Range(Names("gstrEmail2HTMLBodyLine_28")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail2HTMLBodyLine_29")).Offset(0, 1).Value) <> "" Then gstrEmail2HTMLBodyLine(29) = Range(Names("gstrEmail2HTMLBodyLine_29")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail2HTMLBodyLine_30")).Offset(0, 1).Value) <> "" Then gstrEmail2HTMLBodyLine(30) = Range(Names("gstrEmail2HTMLBodyLine_30")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail2HTMLBodyLine_31")).Offset(0, 1).Value) <> "" Then gstrEmail2HTMLBodyLine(31) = Range(Names("gstrEmail2HTMLBodyLine_31")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail2HTMLBodyLine_32")).Offset(0, 1).Value) <> "" Then gstrEmail2HTMLBodyLine(32) = Range(Names("gstrEmail2HTMLBodyLine_32")).Offset(0, 1).Value
If CStr(Range(Names("gstrEmail2HTMLBodyLine_33")).Offset(0, 1).Value) <> "" Then gstrEmail2HTMLBodyLine(33) = Range(Names("gstrEmail2HTMLBodyLine_33")).Offset(0, 1).Value
End Sub
' There must be a worksheet named VariableValues
If Not SheetExists("VariableValues") Then
gvarMessage = MsgBox("There must be a worksheet named 'VariableValues' with " _
& "values for over 100 variables.", vbOKOnly, "VariableValues Worksheet not found")
Exit Sub
End If
' Set the Default variable values or the User values according to the user selection.
If Worksheets("VariableValues").Cells(4, 3) = True Then
SetDefaultValues
Else
SetUserValues
End If
End Sub
Dim wks As Worksheet
Dim strUpperName As String
' To reset the combo box list values showing the NewList and PrevList
' worksheet names
With Worksheets("DataViewForm1").cboNewList
.ColumnCount = 1
.ListRows = 8
.BoundColumn = 1
.ColumnWidths = "4 cm"
.ListWidth = "4 cm"
.Clear
For Each wks In Worksheets
strUpperName = Left(WorksheetFunction.Proper(wks.Name), 3)
If strUpperName = Left(WorksheetFunction.Proper(gstrFilenameFormat), 3) _
Or (wks.Name = gstrSelectedList) Then
.AddItem wks.Name
End If
Next
If SheetExists(gstrNewList) Then
.Text = gstrNewList
.Value = gstrNewList
Else
.Value = cSelect
End If
End With
With Worksheets("DataViewForm1").cboPrevList
.ColumnCount = 1
.ListRows = 8
.BoundColumn = 1
.ColumnWidths = "4 cm"
.ListWidth = "4 cm"
.Clear
For Each wks In Worksheets
strUpperName = Left(WorksheetFunction.Proper(wks.Name), 3)
If strUpperName = Left(WorksheetFunction.Proper(gstrFilenameFormat), 3) _
Or (wks.Name = gstrSelectedList) Then
.AddItem wks.Name
End If
Next
If SheetExists(gstrPrevList) Then
.Text = gstrPrevList
.Value = gstrPrevList
Else
.Value = cSelect
End If
End With
End Sub
Dim wks As Worksheet
Dim strUpperName As String
Dim strPresentValue As String
' To reset the combo box list values showing the NewList and PrevList
' worksheet names
With Worksheets("DataViewForm1").cboSourceDataWorksheet
strPresentValue = .Value
.Clear
For Each wks In Worksheets
strUpperName = Left(WorksheetFunction.Proper(wks.Name), 3)
If strUpperName = Left(WorksheetFunction.Proper(gstrFilenameFormat), 3) _
Or (wks.Name = gstrSelectedList) Then
.AddItem wks.Name
End If
Next
If SheetExists(strPresentValue) Then
.Value = strPresentValue
Else
.Value = cSelect
End If
End With
End Sub
Dim wks As Worksheet
Dim strUpperName As String
AddSheetToCombo = False
With Worksheets("DataViewForm1").cboNewList
.Clear
For Each wks In Worksheets
strUpperName = Left(WorksheetFunction.Proper(wks.Name), 3)
If strUpperName = Left(WorksheetFunction.Proper(gstrFilenameFormat), 3) _
Or (wks.Name = gstrSelectedList) Then
.AddItem wks.Name
End If
Next
End With
With Worksheets("DataViewForm1").cboPrevList
.Clear
For Each wks In Worksheets
strUpperName = Left(WorksheetFunction.Proper(wks.Name), 3)
If strUpperName = Left(WorksheetFunction.Proper(gstrFilenameFormat), 3) _
Or (wks.Name = gstrSelectedList) Then
.AddItem wks.Name
End If
Next
End With
If bolIsNew Then ' there has been a NewList import
If SheetExists(gstrListSheetName) Then
Worksheets("DataViewForm1").cboNewList.Value = gstrListSheetName
If SheetExists(gstrPrevList) Then
Worksheets("DataViewForm1").cboPrevList.Value = gstrPrevList
Else
Worksheets("DataViewForm1").cboPrevList.Value = cSelect
End If
Else
Worksheets("DataViewForm1").cboNewList.Value = cSelect
If SheetExists(gstrPrevList) Then
Worksheets("DataViewForm1").cboPrevList.Value = gstrPrevList
Else
Worksheets("DataViewForm1").cboPrevList.Value = cSelect
End If
End If
Else ' There has been a PrevList import
If SheetExists(gstrListSheetName) Then
Worksheets("DataViewForm1").cboPrevList.Value = gstrListSheetName
If SheetExists(gstrNewList) Then
Worksheets("DataViewForm1").cboNewList.Value = gstrNewList
Else
Worksheets("DataViewForm1").cboNewList.Value = cSelect
End If
Else
Worksheets("DataViewForm1").cboPrevList.Value = cSelect
If SheetExists(gstrNewList) Then
Worksheets("DataViewForm1").cboNewList.Value = gstrNewList
Else
Worksheets("DataViewForm1").cboNewList.Value = cSelect
End If
End If
End If
ExitNormal:
AddSheetToCombo = True
Exit Function
ExitError:
AddSheetToCombo = False
End Function
' Import a .csv file
If Not ImportFile(bolNew) Then GoTo ExitError
' Format the file to set the column headers and col. width.
If Not FormatRawImport(bolNew) Then GoTo ExitError
' Clean the imported data list
If Not CleanData(gstrNewList) Then GoTo ExitError
ExitNormal:
Exit Sub
ExitError:
gvarMessage = MsgBox("File Import, Format or Data Cleansing failed. " _
& "as described in a previous message for some errors.", vbOKOnly, "Import Error")
End Sub
' Import a .csv file
If Not ImportFile(bolPrev) Then GoTo ExitError
' Format the file to set the column headers and col. width.
If Not FormatRawImport(bolPrev) Then GoTo ExitError
' Clean the imported data list
If Not CleanData(gstrPrevList) Then GoTo ExitError
ExitNormal:
Exit Sub
ExitError:
gvarMessage = MsgBox("File Import, Format or Data Cleansing failed. " _
& "as described in a previous message for some errors.", vbOKOnly, "Import Error")
End Sub
'
' Import Data File
' Import File of CSV Data, the file is old data unless bolIsNew is True
' Macro recorded 4 Feb 2002 by Dr. Meshkot
'
Dim strFilenamePath As String
Dim strFilename
Dim intCounterA
Dim intCounter
On Error GoTo ExitError1
ImportFile = False
SetVariableValues
' Get filename if it was left blank in Defaults.
If bolIsNew Then
If gstrNewListFilename = "" Or _
gstrNewListFilename = "ASK USER ON IMPORT" Then
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = False
.InitialView = msoFileDialogViewDetails
.InitialFileName = gstrFilePath
If .Show = 0 Then Exit Function
strFilenamePath = .SelectedItems(1)
End With
gstrNewListFilename = FilenamePart(strFilenamePath)
If Left(gstrNewListFilename, 5) = "ERROR" Then GoTo ExitError1
Else
strFilenamePath = gstrFilePath & gstrNewListFilename
End If
' Set the temp worksheet name gstrListSheetName (temp because
' the worksheet does not exist yet) from the gstrNewListFilename
gstrListSheetName = WorksheetFunction.Proper(Left(gstrNewListFilename, Len(gstrNewListFilename) - 4))
Else
If gstrPrevListFilename = "" Or _
gstrPrevListFilename = "ASK USER ON IMPORT" Then
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = False
.InitialView = msoFileDialogViewDetails
.InitialFileName = gstrFilePath
If .Show = 0 Then Exit Function
strFilenamePath = .SelectedItems(1)
End With
gstrPrevListFilename = FilenamePart(strFilenamePath)
If Left(gstrPrevListFilename, 5) = "ERROR" Then GoTo ExitError1
Else
strFilenamePath = gstrFilePath & gstrPrevListFilename
End If
' Set the worksheet name from the gstrListSheetName
gstrListSheetName = WorksheetFunction.Proper(Left(gstrPrevListFilename, Len(gstrPrevListFilename) - 4))
End If
' Check for existing sheet name.
If SheetExists(gstrListSheetName) Then GoTo ExitError2
ActiveWorkbook.Worksheets.Add
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" & strFilenamePath, Destination:=Range("A1"))
.Name = ""
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 720
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = True
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
ActiveSheet.Name = gstrListSheetName
ActiveSheet.Move before:=Worksheets("DataViewForm1")
' Add the new worksheet name to the combo box selection lists
If Not AddSheetToCombo(bolIsNew) Then GoTo ExitError3
ResetSourceDataCombo
ExitNormal:
ImportFile = True
Exit Function
ExitError1:
If bolIsNew Then
gvarMessage = MsgBox("Unable to Import file " _
& vbCrLf & strFilenamePath & vbCrLf _
& "Into a new worksheet named " & gstrNewList _
& ". Check User Valus.", vbOKOnly, "Unable to Import")
Else
gvarMessage = MsgBox("Unable to Import file " _
& vbCrLf & strFilenamePath & vbCrLf _
& "Into a new worksheet named " & gstrPrevList _
& ". Check User Valus.", vbOKOnly, "Unable to Import")
End If
GoTo ExitError
ExitError2:
gvarMessage = MsgBox("Importing list would create " _
& "duplicate worksheet names. Delete the worksheet named:" _
& vbCrLf & gstrListSheetName & vbCrLf _
& "or provide a different name in the VariableValues worksheet. ", _
vbOKOnly, "Unable to Import")
GoTo ExitError
ExitError3:
gvarMessage = MsgBox("Unable to add the Imported Data Worksheet Name " _
& vbCrLf & gstrListSheetName & vbCrLf _
& "to the combo box selection list. ", _
vbOKOnly, "Unable to Add Worksheet Name")
ExitError:
ImportFile = False
End Function
'
' FormatRawImport function
' Add Column Headings and Auto filter.
' Macro created 4 Feb 2002 by Dr. Meshkot
'
Dim strSheetName As String
Dim intCounter As Integer
On Error GoTo ExitError
FormatRawImport = False
If bolIsNew Then
If Not SheetExists(gstrNewList) Then GoTo ExitError
strSheetName = gstrNewList
Else
If Not SheetExists(gstrPrevList) Then GoTo ExitError
strSheetName = gstrPrevList
End If
Sheets(strSheetName).Select
Range("A1").Select
Selection.EntireRow.Insert
' set column heading and width
For intCounter = 1 To cDataColCount
With Range("A1").Offset(0, intCounter - 1)
.Value = gstrColHeading(intCounter)
.Font.Bold = True
.Font.Size = 12
.Interior.ColorIndex = colGrey
End With
Columns(intCounter).ColumnWidth = gintListColWidth
Next
ExitNormal:
FormatRawImport = True
Exit Function
ExitError:
FormatRawImport = False
If bolIsNew Then
gvarMessage = MsgBox("Unable to set column headings " _
& "for worksheet named " & gstrNewList _
& ". Check User Values.", vbOKOnly, "Unable to Set Headings")
Else
gvarMessage = MsgBox("Unable to set column headings " _
& "for worksheet named " & gstrPrevList _
& ". Check User Values.", vbOKOnly, "Unable to Set Headings")
End If
End Function
Dim intCounter As Long
On Error GoTo ExitError
FilenamePart = ""
If Len(strFilePath) < 5 Then GoTo ExitError ' 5 characters, e.g. 1.csv
For intCounter = Len(strFilePath) To 1 Step -1
If Mid(strFilePath, intCounter, 1) = "\" Then
FilenamePart = Right(strFilePath, Len(strFilePath) - intCounter)
GoTo ExitNormal
End If
Next
ExitNormal:
Exit Function
ExitError:
FilenamePart = "ERROR in CSV filename/path"
End Function
' This module is for cleaning the data and comparing
' new data with previous data.
' By: Dr. M. A. Meshkot
' 12 Feb 2002
' 138011231353
' By: M. A. Meshkot
' 19 December 2001 00:50
' This routine is to clean the downloaded and imported data
' "Clean" here means removing entire rows where the specified column
' contains invalid data
' For Salesserve Reference column, Valid data begin with SS.
Dim LastCellRow
On Error GoTo ExitError
CleanData = False
If SheetExists(strSheetName) Then
Sheets(strSheetName).Activate
Else
GoTo ExitError1
End If
' Move to the column for which all records have a value
' or otherwisr find the last row of data
If gintDataCleanColumnRelative >= 0 Then
Range("A2").Offset(0, gintDataCleanColumnRelative).Select
' Find the last cell in this column
LastCellRow = Selection.End(xlDown).Row
Else
Range("A2").Select
LastCellRow = ActiveCell.Cells.SpecialCells(xlCellTypeLastCell).Row
End If
' Move to the data comparison column
Range("A2").Offset(0, gintDataCompareColumnRelative).Select
' Find the missing or invalid Sales references and delete that row.
' Reduce the last row number whenever a row is deleted.
Application.ScreenUpdating = False
While ActiveCell.Row < LastCellRow
If (CStr(ActiveCell.Value) = "") _
Or (Left(CStr(ActiveCell.Value), 2) <> "SS") Then
ActiveCell.EntireRow.Delete
LastCellRow = LastCellRow - 1
ActiveCell.Offset(-1, 0).Activate
End If
ActiveCell.Offset(1, 0).Activate
Wend
Application.ScreenUpdating = True
Range("A1").Select
ExitNormal:
CleanData = True
Exit Function
ExitError1:
gvarMessage = MsgBox("Unable to Clean Data because Worksheet " _
& strSheetName _
& " does not exist", vbOKOnly, "Clean Data Error")
ExitError:
CleanData = False
gvarMessage = MsgBox("Unable to Clean Data in worksheet " _
& strSheetName _
& ". Check user values in " _
& " VariableValues worksheet", vbOKOnly, "Data Clensing Error")
End Function
' To Mark records that are NEW compared to previous download
' In fact Two worksheets are compared here
' The worksheet names are taken from the New List and Prev List combo
' boxes on the data view form 1
Dim LookupResult As Variant
Dim OldListKey As Variant
Dim NewListKey As Variant
Dim LastCellInColAddress As Variant
Dim NewItemCount As Long
Dim lngScreenUpdatingCounter As Long
Dim lngLastDataRow As Long
Dim varCurrentZoom, varCurrentCellAddress
On Error GoTo ExitError2
lngScreenUpdatingCounter = 0
' Check to see that we have 2 Sales lists imported.
If gstrNewList = "" Or gstrPrevList = "" Then SetDefaultValues
If (Not SheetExists(gstrNewList)) _
Or (Not SheetExists(gstrPrevList)) Then
GoTo ExitError1
End If
' Name the old list's Key column (or Field)
Sheets(gstrPrevList).Activate
Range("A2").Offset(0, gintDataCompareColumnRelative).Select
' Find the last cell in this column
LastCellInColAddress = Selection.End(xlDown).Address
ActiveWorkbook.Names.Add _
Name:="PrevListKeyField", _
RefersTo:="=" & ActiveSheet.Name & "!" _
& Range("A2").Offset(0, gintDataCompareColumnRelative).Address _
& ":" & LastCellInColAddress
' Name the New list's Key column (or Field)
Sheets(gstrNewList).Activate
Range("A2").Offset(0, gintDataCompareColumnRelative).Select
' Find the last cell in this column
LastCellInColAddress = Selection.End(xlDown).Address
ActiveWorkbook.Names.Add _
Name:="NewListKeyField", _
RefersTo:="=" & ActiveSheet.Name & "!" _
& Range("A2").Offset(0, gintDataCompareColumnRelative).Address _
& ":" & LastCellInColAddress
' Set display
varCurrentZoom = ActiveWindow.Zoom
varCurrentCellAddress = ActiveCell.Offset(0, 2).Address
Range("A2:" & varCurrentCellAddress).Select
ActiveWindow.Zoom = True
Application.ScreenUpdating = False
On Error GoTo ExitError
' Use the VLookup worksheet function on the worksheet
' and use its results to mark the row if it is a new item
' The method is as follows:
For Each NewListKey In Range(Names("NewListKeyField"))
lngScreenUpdatingCounter = lngScreenUpdatingCounter + 1
' Show screen updating at the intervals selected by the user
If lngScreenUpdatingCounter >= gIntShowScreenInterval Then
Application.ScreenUpdating = True
' Scroll to the leftmost
ActiveWindow.ScrollColumn = 1
lngScreenUpdatingCounter = 0 ' Reset the counter
Else
Application.ScreenUpdating = False
End If
NewListKey.Activate
' The following IF statement prevents rechecking a cell that is
' already marked as a new Sales ref.
If ActiveCell.Interior.ColorIndex = gMarkColourNew Then
NewItemCount = NewItemCount + 1
GoTo NextNewKeyList
End If
' Move to the Temporary column and insert a VLOOKUP formula
ActiveCell.Offset(0, gintTempColumnNumberRelative).Range("A1").Select
Application.StatusBar = "Processing Row " & ActiveCell.Row
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-" & gintTempColumnNumberRelative _
& "],PrevListKeyField,1,0)"
' ReCalculate
' Error 2042 means the cell shows "#N/A" which means the KEY
' is new. The IsNA function must be used to test for this value.
ActiveSheet.Columns(ActiveCell.Column).Calculate
If Application.WorksheetFunction.IsNA(ActiveCell.Value) Then
ActiveSheet.Cells(ActiveCell.Row, 1 + gintMarkColumnNumberNewRelative).Select
Selection.Interior.ColorIndex = gMarkColourNew
NewItemCount = NewItemCount + 1
' Return to the Temporary column, after marking the marked column,
' and delete the temporary lookup formula.
ActiveSheet.Cells(ActiveCell.Row, _
1 + gintDataCompareColumnRelative _
+ gintTempColumnNumberRelative).Select
End If
ActiveCell.Clear
NextNewKeyList:
Next
lngLastDataRow = ActiveCell.Row
Application.ScreenUpdating = True
ActiveWindow.Zoom = varCurrentZoom
Range("A1").Activate
ActiveWindow.ScrollColumn = 1
If Not SheetExists("CompareResult") Then
ActiveWorkbook.Sheets.Add
ActiveSheet.Name = "CompareResult"
End If
Worksheets("CompareResult").Activate
ActiveSheet.Range("A1").Select
Selection.SpecialCells(xlCellTypeLastCell).Select
ActiveCell.End(xlToLeft).Offset(1, 0).Select
With ActiveCell
.Offset(0, 0).Value = Now
.Offset(0, 1).Value = "Worksheet"
.Offset(0, 2).Value = gstrNewList
.Offset(0, 3).Value = "Contained"
.Offset(0, 4).Value = NewItemCount
.Offset(0, 5).Value = "New Records out of "
.Offset(0, 6).Value = lngLastDataRow - 1
.Offset(0, 7).Value = "Records when Relative Column"
.Offset(0, 8).Value = gintDataCompareColumnRelative
.Offset(0, 9).Value = "was compared with Worksheet"
.Offset(0, 10).Value = gstrPrevList
End With
ActiveSheet.Columns("A:K").AutoFit
gvarMessage = MsgBox("The next message box will ask you to confirm that " _
& "you wish to delete the old/previous data. This is based on your " _
& "selection in the Variable Values worksheet.", vbOKOnly, "Confirm Delete")
If gbolDeleteOldList Then
Worksheets(gstrPrevList).Delete
End If
NormalExit:
Exit Sub
ExitError1:
gvarMessage = MsgBox("Unable to compare worksheet '" _
& gstrNewList & "' with worksheet '" _
& gstrPrevList & "' because one or both worksheet " _
& "does not exist. " _
& "If data has not been imported during this session, then " _
& "set the name of the New and Previous worksheets to be compared as a user " _
& "variable in the VariableValues worksheet.", vbOKOnly, "Data Comparison Error")
Exit Sub
ExitError2:
gvarMessage = MsgBox("Unable to compare worksheet " _
& gstrNewList & " with worksheet " _
& gstrPrevList & " . There was an error naming column ranges " _
& "to compare.", vbOKOnly, "Data Comparison Error")
Exit Sub
ExitError:
gvarMessage = MsgBox("Unable to compare worksheet " _
& gstrNewList & " with worksheet " _
& gstrPrevList & " . There was an error when comparing the data " _
& "or marking new items or writing the compare results to " _
& "worksheet CompareResult. Check the Variable Values, in particular:" _
& " -gIntShowScreenInterval = " & gIntShowScreenInterval _
& " -gintTempColumnNumberRelative(to key) = " & gintTempColumnNumberRelative _
& " -gintMarkColumnNumberNewRelative(to column A) = " & gintMarkColumnNumberNewRelative _
& " -gMarkColourNew = " & gMarkColourNew _
, vbOKOnly, "Data Comparison Error")
End Sub
Dim intCounter As Integer
' step through the worksheet names
For intCounter = 1 To Worksheets.Count
If Left(Worksheets(intCounter).Name, 3) = Left(gstrFilenameFormat, 3) Then
If WorksheetList <> "" Then
WorksheetList = WorksheetList & "," & Worksheets(intCounter).Name
Else
WorksheetList = Worksheets(intCounter).Name
End If
End If
Next
End Function
' This module is for filtering the data
' By: Dr. M. A. Meshkot
' 23 April 2002
' 138102030851
'
' ApplyAdvancedFilter
' Macro Created 23/04/2002 by Dr. Meshkot
'
If SheetExists(strSheetToFilter) Then
Worksheets(strSheetToFilter).Activate
Else
gvarMessage = MsgBox("Datalist Worksheet " & strSheetToFilter & " does not exist", vbOKOnly, _
"Nothing to Filter")
Exit Sub
End If
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
Select Case intFilter
Case Is = 1
If Not SheetExists(gstrFilter1) Then
gvarMessage = MsgBox("Missing Filter Worksheet " _
& gstrFilter1 _
& " Try initializing the data view form " _
& "and check variable values worksheet", vbOKOnly, _
"Missing Filter")
Exit Sub
End If
Case Is = 2
If Not SheetExists(gstrFilter2) Then
gvarMessage = MsgBox("Missing Filter Worksheet " _
& gstrFilter2 _
& " Try initializing the data view form " _
& "and check variable values worksheet", vbOKOnly, _
"Missing Filter")
Exit Sub
End If
Case Is = 3
If Not SheetExists(gstrFilter3) Then
gvarMessage = MsgBox("Missing Filter Worksheet " _
& gstrFilter3 _
& " Try initializing the data view form " _
& "and check variable values worksheet", vbOKOnly, _
"Missing Filter")
Exit Sub
End If
End Select
Select Case intFilter
Case Is = 1
ActiveSheet.UsedRange.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:= _
Sheets(gstrFilter1).UsedRange, Unique:=False
Worksheets("DataViewForm1").txtFilteredCount _
= WorksheetFunction.DCountA(Sheets(strSheetToFilter).UsedRange, _
3, Sheets(gstrFilter1).UsedRange)
Case Is = 2
ActiveSheet.UsedRange.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:= _
Sheets(gstrFilter2).UsedRange, Unique:=False
Worksheets("DataViewForm1").txtFilteredCount _
= WorksheetFunction.DCountA(Sheets(strSheetToFilter).UsedRange, _
3, Sheets(gstrFilter2).UsedRange)
Case Is = 3
ActiveSheet.UsedRange.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:= _
Sheets(gstrFilter3).UsedRange, Unique:=False
Worksheets("DataViewForm1").txtFilteredCount _
= WorksheetFunction.DCountA(Sheets(strSheetToFilter).UsedRange, _
3, Sheets(gstrFilter3).UsedRange)
Case Is = 4
ActiveSheet.UsedRange.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:= _
Sheets(gstrFilter4).UsedRange, Unique:=False
Worksheets("DataViewForm1").txtFilteredCount _
= WorksheetFunction.DCountA(Sheets(strSheetToFilter).UsedRange, _
3, Sheets(gstrFilter4).UsedRange)
End Select
End Sub
' By: M. A. Meshkot
' 26 April 2002 00:25
' Set the worksheet name for copy destination
Dim strFirstCellInColAddress As String
Dim strLastCellInColAddress As String
Dim strAttachFilePath As String
Dim intCounter As Integer
Dim CellObject
' Check that the source and destination worksheets exists
'* suspended 29/4/2002 17:22 gstrSourceDataWorksheetName = Worksheets("DataViewForm1").cboSourceDataWorksheet.Value
If Not SheetExists(gstrSourceDataWorksheetName) Then GoTo ExitError1
If Not SheetExists(gstrSelectedList) Then GoTo ExitError2
' Move to the Selected marked column on the Source worksheet
Worksheets(gstrSourceDataWorksheetName).Activate
strFirstCellInColAddress = Range("A1").Offset(0, gintMarkColumnNumberSelectRelative).Address
Range(strFirstCellInColAddress).Select
' Find the last row (cell) of the Marked Column on the source worksheet
strLastCellInColAddress = Selection.End(xlDown).Address
' Find the Marked (highlighted) cells in the mark column on the source worksheet
For Each CellObject In Range(strFirstCellInColAddress & ":" & strLastCellInColAddress)
If CellObject.Interior.ColorIndex = gMarkColourSelect Then
CellObject.Activate
' Say that the Marked record has been (is about to be) copied to the Selection worksheet.
ActiveCell.Interior.ColorIndex = gMarkColourCopied
' Get the attachment address from the attachment column on the source data worksheet
strAttachFilePath = ActiveCell.Offset(0, gintAttachmentAdsColNumberRel)
' Move to the first col of this source worksheet row (first field of this
' marked record) and select to the last column of data
ActiveCell.Offset(0, -gintMarkColumnNumberSelectRelative).Range(Cells(1, 1), Cells(1, cDataColCount)).Select
Selection.Copy ' from the source worksheet
Sheets(gstrSelectedList).Activate ' select the destination worksheet
ActiveSheet.Cells(1, gintPasteColumnNumber).Select ' go to the first cell in the destination column
' Use control down-arrow to get to the last row and then move down 1 more
Selection.End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste
' Scrap the copy selection
Application.CutCopyMode = False
' Add the attachment FilePath as the last column
ActiveCell.Offset(0, cDataColCount - gintMarkColumnNumberSelectRelative + 1).Value = strAttachFilePath
' Move back 2 column before the first data column on this row to write-in the date of Selection.
ActiveCell.Offset(0, gintMarkColumnNumberSelectRelative - 1 - 2).Value = Now()
' Move back 1 column before the first data column on this row to write-in the Source Data name.
ActiveCell.Offset(0, gintMarkColumnNumberSelectRelative - 1 - 1).Value = gstrSourceDataWorksheetName
' Add a column for the FollowUp Date.
ActiveCell.Offset(0, cDataColCount + 2).Value = Date + gintEmail1Email2Delay
ActiveCell.Offset(0, cDataColCount + 2).Interior.ColorIndex = gMarkColourBeforeEmail2
' Indicate by colour that email has not been sent yet.
ActiveCell.Offset(0, gintMarkColumnNumberSelectRelative).Interior.ColorIndex = gMarkColourCopied
' Return to the item list worksheet.
ActiveCell.End(xlToLeft).Activate
Sheets(gstrSourceDataWorksheetName).Activate
End If
Next
ActiveCell.End(xlToLeft).Activate
ExitNormal:
Exit Sub
ExitError1:
gvarMessage = MsgBox("Selected source data Worksheet " & gstrSourceDataWorksheetName _
& " does not exist", vbOKOnly, _
"Misssing Worksheet")
Exit Sub
ExitError2:
gvarMessage = MsgBox("Copy destination Worksheet " & gstrSelectedList _
& " does not exist. Check variable values", vbOKOnly, _
"Misssing Worksheet")
End Sub
' This module will send 2 emails at defined intervals with provocation
' The email text is taken from the VariableValue worksheet.
' When user values are left blank (empty string),
' then the default values are used.
' Dr. M. A. Meshkot 26 April 2002
' 1380206
Option Explicit
' To send email 1 for selected items copied to the Selected Worksheet
' for which Email1 has not been sent yet.
' The selection criteria is the colour of the marked column.
' The colour and the column are both variables in the VariableValue worksheet
' The method is:
' 1. Find rows with selected colour in the selected column.
' 2. Create email details from that row.
'
' For columns we have:
' <Selection Date><Source><Data columns><Attachment Address><Email2Date><Response>
'
Dim CellObject, LastRowAddress
' These are the fields which makeup one record of selected rows of imported data
Dim strDataCell(1 To 50) As String
Dim strHTMLBody(1 To 100) As String
Dim strDataRecordAndLabel As String ' One record of the selected items
Dim strEmailBody As String
Dim strEmailSubject As String
Dim strEmailAddress As String
Dim strEmailTo As String
Dim EmailAttachment As String
Dim strFirstCellInColAddress As String
Dim strLastCellInColAddress As String
Const cMaxEmailBatchSize = 15
Const Para = vbCrLf + vbCrLf
Const NewLine = vbCrLf
Const HTMLBreak = "<br>"
Dim objEmailOne(1 To cMaxEmailBatchSize)
Dim intCounter As Integer
Dim objNS, objInBox
Dim objOL As Outlook.Application
Dim intEmailCounter As Integer
Set objOL = New Outlook.Application
Set objNS = objOL.GetNameSpace("MAPI")
Set objInBox = objNS.GetDefaultFolder(olFolderInbox)
intEmailCounter = 1
' Reset Variable Values
SetVariableValues
Sheets(gstrSelectedList).Activate
' Move to the title column, which is marked
strFirstCellInColAddress = _
Range("A1").Offset(0, gintPasteColumnNumber - 1 + gintMarkColumnNumberSelectRelative).Address
Range(strFirstCellInColAddress).Select
' Find the last cell of this Selected List worksheet marked column
strLastCellInColAddress = Selection.End(xlDown).Address
' Find the differently highlighted cells in the marked column
For Each CellObject In Range(strFirstCellInColAddress & ":" & strLastCellInColAddress)
If (CellObject.Interior.ColorIndex = gMarkColourCopied) _
And (intEmailCounter <= gintEmailBatchSize) Then
' Create new email object
Set objEmailOne(intEmailCounter) = objOL.CreateItem(olMailItem)
strEmailBody = ""
' Activate the marked cell
CellObject.Activate
' Assign values to recreate the selected records with labels as in column headings
strDataCell(1) = gstrColHeading(1) & ": " & ActiveCell.Offset(0, -1).Value
strDataCell(2) = gstrColHeading(2) & ": " & ActiveCell.Offset(0, 0).Value
objEmailOne(intEmailCounter).Subject = ActiveCell.Offset(0, 0).Value
strDataCell(3) = gstrColHeading(3) & ": " & ActiveCell.Offset(0, 1).Value
strDataCell(4) = gstrColHeading(4) & ": " & ActiveCell.Offset(0, 2).Value
strDataCell(5) = gstrColHeading(5) & ": " & ActiveCell.Offset(0, 3).Value
strDataCell(6) = gstrColHeading(6) & ": " & ActiveCell.Offset(0, 4).Value
strDataCell(7) = gstrColHeading(7) & ": " & ActiveCell.Offset(0, 5).Value
strDataCell(8) = gstrColHeading(8) & ": " & ActiveCell.Offset(0, 6).Value
strDataCell(9) = gstrColHeading(9) & ": " & ActiveCell.Offset(0, 7).Value
strEmailTo = ActiveCell.Offset(0, 7).Value
strDataCell(10) = gstrColHeading(10) & ": " & ActiveCell.Offset(0, 8).Value
strDataCell(11) = gstrColHeading(11) & ": " & ActiveCell.Offset(0, 9).Value
strEmailAddress = ActiveCell.Offset(0, 10).Value
' Set the email address
If Len(strEmailAddress) > 5 Then ' 5= minimum email address length
strDataCell(12) = gstrColHeading(12) & ": " & strEmailAddress
objEmailOne(intEmailCounter).Recipients.Add (strEmailAddress)
Else
gvarMessage = MsgBox("Item at row " _
& ActiveCell.Offset(0, 10).Row _
& " Does not have an email address" & vbCrLf _
& " Will mark and continue", vbOKOnly, "No Email Address")
objEmailOne(intEmailCounter).Delete
ActiveCell.Interior.ColorIndex = 7
GoTo NextCellObject
End If
' set the last 2 columns (web address and reference for Salesserve files)
strDataCell(13) = gstrColHeading(13) & ": " & ActiveCell.Offset(0, 11).Value
strDataCell(14) = gstrColHeading(14) & ": " & ActiveCell.Offset(0, 12).Value
' Set the email subject
objEmailOne(intEmailCounter).Subject = _
"Invoice for: " _
& objEmailOne(intEmailCounter).Subject _
& " - " & strDataCell(14)
' Set the email attachment address
EmailAttachment = ActiveCell.Offset(0, gintAttachmentAdsColNumberRel).Value
' The full Selected Record (Data Item) is the sum of the Data Cells
strDataRecordAndLabel = ""
For intCounter = 1 To cDataColCount
strDataRecordAndLabel = strDataRecordAndLabel & strDataCell(intCounter) & NewLine
Next
' Now create the email body
strEmailBody = ""
Debug.Print "--------------------------------"; Now
For intCounter = 1 To cEmail1Lines
Debug.Print intCounter, gstrEmail1HTMLBodyLine(intCounter)
If gstrEmail1HTMLBodyLine(intCounter) = "[Recipient Name]" Then
strEmailBody = strEmailBody & strEmailTo
GoTo NextLineOfEmail
ElseIf gstrEmail1HTMLBodyLine(intCounter) = "[Selected Item]" Then
strEmailBody = strEmailBody & strDataRecordAndLabel
GoTo NextLineOfEmail
Else
strEmailBody = strEmailBody & gstrEmail1HTMLBodyLine(intCounter)
End If
NextLineOfEmail:
Next
objEmailOne(intEmailCounter).Body = ""
objEmailOne(intEmailCounter).HTMLBody = ""
objEmailOne(intEmailCounter).HTMLBody = strEmailBody
' Add the attachment
On Error Resume Next
objEmailOne(intEmailCounter).Attachments.Add (EmailAttachment)
objEmailOne(intEmailCounter).Categories = "MAM750 Sales Search"
On Error GoTo 0
' Display email and indicate (by colour) that it was sent out of Excel.
objEmailOne(intEmailCounter).Display
ActiveCell.Interior.ColorIndex = gMarkColourAfterEmail1
' Increment the email counter
intEmailCounter = intEmailCounter + 1
End If
NextCellObject:
Next
End Sub
' To send follow-up email 2 for marked items copied to the Selected Worksheet
' for which Email2 has not been sent yet.
' The follow-up date is set when records are copied to the Selected worksheet.
' The selection criteria is the colour of the follow-up column.
' The colour is a variable gMarkColourBeforeEmail2 in the VariableValue worksheet
' The method is:
' 1. Find rows with selected colour in the selected column.
' 2. Create email details from that row.
'
' For columns we have:
' <Selection Date><Source><Data columns><Attachment Address><Email2Date><Response>
'
Dim CellObject, LastRowAddress
' These are the fields which makeup one record of selected rows of imported data
Dim strDataCell(1 To 50) As String
Dim strHTMLBody(1 To 50) As String
Dim strDataRecordAndLabel As String ' One record of the selected items
Dim strEmailBody As String
Dim strEmailSubject As String
Dim strEmailAddress As String
Dim strEmailTo As String
Dim strEmail1Date As String
Dim EmailAttachment As String ' not used for follow-up
Dim strFirstCellInColAddress As String
Dim strLastCellInColAddress As String
Dim dblLastRowInCol As Double
Const cMaxEmailBatchSize = 15
Const Para = vbCrLf + vbCrLf
Const NewLine = vbCrLf
Const HTMLBreak = "<br>"
Dim objEmailTwo(1 To cMaxEmailBatchSize)
Dim intCounter As Integer
Dim objNS, objInBox
Dim objOL As Outlook.Application
Dim intEmailCounter As Integer
Set objOL = New Outlook.Application
Set objNS = objOL.GetNameSpace("MAPI")
Set objInBox = objNS.GetDefaultFolder(olFolderInbox)
intEmailCounter = 1
' Reset Variable Values
SetVariableValues
If SheetExists(gstrSelectedList) Then
Sheets(gstrSelectedList).Activate
Else
gvarMessage = MsgBox("There is no selected records worksheet named " _
& gstrSelectedList, vbOKOnly, "Missing Worksheet")
Exit Sub
End If
' Move to the title column, which is marked
strFirstCellInColAddress = _
Range("A1").Offset(0, cFollowUpColRelative).Address
Range(strFirstCellInColAddress).Select
' Find the last row of this Selected List worksheet follow-up column
' Since the follow-up date column is the last column, then the last cell
' in the used range will be the last cell in the follow-up column.
' However, I must consider that other columns may be added in the future.
' To make this consideration, I will use the Last Row Number in the
' follow-up column, instead of the LastCellInColumn.
dblLastRowInCol = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row
' Find the differently highlighted cells in the marked column
For Each CellObject In Range(strFirstCellInColAddress & ":" _
& Range(strFirstCellInColAddress).Offset(dblLastRowInCol, 0).Address)
If (CellObject.Interior.ColorIndex = gMarkColourBeforeEmail2) _
And (intEmailCounter <= gintEmailBatchSize) _
And (CellObject.Value <= Date) Then
' Create new email object
Set objEmailTwo(intEmailCounter) = objOL.CreateItem(olMailItem)
strEmailBody = ""
' Activate the marked cell
CellObject.Activate
' Assign values to recreate the selected records with labels as in column headings
strDataCell(1) = gstrColHeading(1) & ": " & ActiveCell.Offset(0, -16).Value
strDataCell(2) = gstrColHeading(2) & ": " & ActiveCell.Offset(0, -15).Value
objEmailTwo(intEmailCounter).Subject = ActiveCell.Offset(0, -15).Value
strDataCell(3) = gstrColHeading(3) & ": " & ActiveCell.Offset(0, -14).Value
strDataCell(4) = gstrColHeading(4) & ": " & ActiveCell.Offset(0, -13).Value
strDataCell(5) = gstrColHeading(5) & ": " & ActiveCell.Offset(0, -12).Value
strDataCell(6) = gstrColHeading(6) & ": " & ActiveCell.Offset(0, -11).Value
strDataCell(7) = gstrColHeading(7) & ": " & ActiveCell.Offset(0, -10).Value
strDataCell(8) = gstrColHeading(8) & ": " & ActiveCell.Offset(0, -9).Value
strDataCell(9) = gstrColHeading(9) & ": " & ActiveCell.Offset(0, -8).Value
strEmailTo = ActiveCell.Offset(0, -8).Value
strDataCell(10) = gstrColHeading(10) & ": " & ActiveCell.Offset(0, -7).Value
strDataCell(11) = gstrColHeading(11) & ": " & ActiveCell.Offset(0, -6).Value
strEmailAddress = ActiveCell.Offset(0, -5).Value
' Set the email address
If Len(strEmailAddress) > 5 Then ' 5= minimum email address length
strDataCell(12) = gstrColHeading(12) & ": " & strEmailAddress
objEmailTwo(intEmailCounter).Recipients.Add (strEmailAddress)
Else
gvarMessage = MsgBox("Item at row " _
& ActiveCell.Row _
& " Does not have an email address" & vbCrLf _
& " Will mark and continue", vbOKOnly, "No Email Address")
objEmailTwo(intEmailCounter).Delete
ActiveCell.Interior.ColorIndex = 7
GoTo NextCellObject
End If
' set the last 2 columns (web address and reference for Salesserve files)
strDataCell(13) = gstrColHeading(13) & ": " & ActiveCell.Offset(0, -4).Value
strDataCell(14) = gstrColHeading(14) & ": " & ActiveCell.Offset(0, -3).Value
' Set the date of Email1
strEmail1Date = Left(CStr(ActiveCell.Offset(0, -18).Value), 10)
' Set the email subject
objEmailTwo(intEmailCounter).Subject = _
"Follow-up for: " _
& objEmailTwo(intEmailCounter).Subject _
& " - " & strDataCell(14)
' Set the email attachment address
' EmailAttachment = ActiveCell.Offset(0, gintAttachmentAdsColNumberRel).Value
' The full Selected Record (Data Item) is the sum of the Data Cells
strDataRecordAndLabel = ""
For intCounter = 1 To cDataColCount
strDataRecordAndLabel = strDataRecordAndLabel & strDataCell(intCounter) & NewLine
Next
' Now create the email body
strEmailBody = ""
Debug.Print "--------------------------------"; Now
For intCounter = 1 To cEmail2Lines
Debug.Print intCounter, gstrEmail2HTMLBodyLine(intCounter)
If gstrEmail2HTMLBodyLine(intCounter) = "[Recipient Name]" Then
strEmailBody = strEmailBody & strEmailTo
GoTo NextLineOfEmail
ElseIf gstrEmail2HTMLBodyLine(intCounter) = "[Email1Date]" Then
strEmailBody = strEmailBody & strEmail1Date
GoTo NextLineOfEmail
Else
strEmailBody = strEmailBody & gstrEmail2HTMLBodyLine(intCounter)
End If
NextLineOfEmail:
Next
objEmailTwo(intEmailCounter).Body = ""
objEmailTwo(intEmailCounter).HTMLBody = ""
objEmailTwo(intEmailCounter).HTMLBody = strEmailBody
' Add the attachment
On Error Resume Next
' objEmailTwo(intEmailCounter).Attachments.Add (EmailAttachment)
objEmailTwo(intEmailCounter).Categories = "MAM750 Sales Search"
On Error GoTo 0
' Display email and indicate (by colour) that it was sent out of Excel.
objEmailTwo(intEmailCounter).Display
ActiveCell.Interior.ColorIndex = gMarkColourAfterEmail2
' Increment the email counter
intEmailCounter = intEmailCounter + 1
End If
NextCellObject:
Next
End Sub
' Import a .csv Sales file
ImportSalesFile (strSalesListToday)
' Format the file to set the column headers, col. width and ACCESS filter.
FormatRawImport (strSalesListToday)
' Clean the Sales list
CleanSaleslistMethod (strSalesListToday)
End Sub
' Import a .csv Sales file
ImportSalesFile (strSalesListPrev)
' Format the file to set the column headers, col. width and ACCESS filter.
FormatRawImport (strSalesListPrev)
' Clean the Sales list
CleanSaleslistMethod (strSalesListPrev)
End Sub
ImportSalesList2DaysOld
ImportSalesList1DayOld
End Sub
' By: Dr. M. A. Meshkot 29 Nov 2001 02:15
' To import the Sales file from 2 days ago.
' First calculate the logical file name SalesYYMMDD.CSV
Dim strSaleslistOldFile As String
strSaleslistOldFile = "Sales" & Format(Format(Date - 2, "yymmdd"), "000000") & ".csv"
strSaleslistOldFile = strFilePath & strSaleslistOldFile
' Import a .csv Sales file
Call ImportNamedSalesFile(strSaleslistOldFile, strSalesListPrev)
' Format the file to set the column headers, col. width and ACCESS filter.
FormatRawImport (strSalesListPrev)
End Sub
' To import the Sales file from 2 days ago.
' First calculate the logical file name SalesYYMMDD.CSV
Dim strSaleslistOldFile As String
strSaleslistOldFile = "Sales" & Format(Format(Date - 1, "yymmdd"), "000000") & ".csv"
strSaleslistOldFile = strFilePath & strSaleslistOldFile
' Import a .csv Sales file
Call ImportNamedSalesFile(strSaleslistOldFile, strSalesListToday)
' Format the file to set the column headers, col. width and ACCESS filter.
FormatRawImport (strSalesListToday)
End Sub
'
' Import Sales Data File Macro
' Import Sales File CSV Data
' Macro recorded 15/10/2001 by Dr. Meshkot
'
Dim strSalesfile As String
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = False
.InitialView = msoFileDialogViewDetails
.InitialFileName = "\\Data2002A\Internet\SalesSearch"
If .Show = 0 Then Exit Sub
strSalesfile = .SelectedItems(1)
End With
Debug.Print Now(); "file name is: "; strSalesfile
'
ActiveWorkbook.Worksheets.Add
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" & strSalesfile, Destination:=Range("A1"))
.Name = ""
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 720
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = True
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
ActiveSheet.Name = strSalesSheetName
End Sub
'
' Import Sales Data File Macro
' Import Sales File CSV Data
' Macro recorded 15/10/2001 by Dr. Meshkot
'
Dim strSalesfile As String
Debug.Print Now(); "Import file name is: "; strNamedSalesFile, "Worksheet Name is: "; strSalesSheetName
'
ActiveWorkbook.Worksheets.Add
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" & strNamedSalesFile, Destination:=Range("A1"))
.Name = ""
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 720
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = True
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
ActiveSheet.Name = strSalesSheetName
End Sub
'
' FormatRawImport Macro
' Add Column Headings and Auto filter.
' Macro recorded 15/10/2001 by Dr. Meshkot
'
' If Not SheetExists(strSheetName) Then Exit Sub
' Sheets("Headers").Select
' Rows("1:1").Select
' Selection.Copy
' Sheets(strSheetName).Select
' Rows("1:1").Select
' Selection.Insert Shift:=xlDown
' Cells.Select
' Selection.ColumnWidth = 9
' Range("B1").Select
' Selection.AutoFilter Field:=2, Criteria1:="=*access*", Operator:=xlAnd
'End Sub
' By: M. A. Meshkot
' 17 October 2001 01:53
'
If Not SheetExists(strSalesListToday) Then Exit Sub
Sheets(strSalesListToday).Activate
' Move to the title column
Range("B2").Select
' Find the last cell in this column
LastCellInColAddress = Selection.End(xlDown).Address
' Find the highlighted cells in Column B
For Each CellObject In Range("B1:" & LastCellInColAddress)
If CellObject.Interior.ColorIndex = 6 Then
CellObject.Activate
ActiveCell.Interior.ColorIndex = 44
' Move to the first col of this row and select to col.N
ActiveCell.Offset(0, -1).Range("A1:N1").Select
Selection.Copy
Sheets("AppliedTo").Activate
Range("B2").Select
' Use control down-arrow to get to the last row and then move down 1 more
Selection.End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste
' Scrap the copy selection
Application.CutCopyMode = False
' Move to col A of this row to write-in the date of Invoice.
Selection.Offset(0, -1).Activate
ActiveCell.Value = Now()
' Move to col Q of this row to write-in the FollowUp Date.
Selection.Offset(0, 16).Activate
ActiveCell.Value = Date + 2
ActiveCell.Interior.ColorIndex = 38
' Return to the Saleslist sheet and move to the right of the last found cell.
Sheets(strSalesListToday).Activate
End If
Next
End Sub
' To send email Invoice for those Sales that have been
' copied to the AppliedTo worksheet, but not yet applied.
' The selection criteria is the colour of the Title column.
' Which must be Orange.
' The method is:
' 1. Find rows of Sales details with orange colour in the title.
' 2. Create email details from that row.
'
Dim CellObject, LastRowAddress
Dim strSalesLine(1 To 50) As String
Dim strHTMLBody(1 To 100) As String
Dim strSalesDetail As String
Dim strEmailBody As String
Dim strEmailSubject As String
Dim strEmailAddress As String
Dim strEmailTo As String
Dim strAboutCV As String
Const Para = vbCrLf + vbCrLf
Const NewLine = vbCrLf
Const HTMLBreak = "<br>"
Const EmailAttachment = "\\Data2002A\Sales2002\SalesAnalysis\Invoice.rtf"
Dim intCounter As Integer
Dim MsgReply
Dim objNS, objInBox
Dim objSalesEmail(1 To 10) ' Number of emails at a time
Dim objOL As Outlook.Application
Dim intEmailCounter As Integer
Set objOL = New Outlook.Application
Set objNS = objOL.GetNameSpace("MAPI")
Set objInBox = objNS.GetDefaultFolder(olFolderInbox)
' Define HTML Body for Email
strHTMLBody(1) = "<HTML><HEAD>"
strHTMLBody(2) = "<TITLE>Sales Email from the Accounts Manager Ali Meshkot</TITLE>"
strHTMLBody(3) = "<META http-equiv=Content-Type content='text/html; charset=utf-8'></HEAD>"
strHTMLBody(4) = "<BODY bgColor=#99ccff LeftMargin=50>"
strHTMLBody(5) = "<BASEFONT='4'></basefont>"
strHTMLBody(6) = "<p><b><font size=+1><span style='BACKGROUND-COLOR: #ffff00'>Dear "
strHTMLBody(7) = "</span> </b></p>"
strHTMLBody(8) = "<p><b>I enclose a copy invoice in response to the "
strHTMLBody(9) = "request you made below.  Please contact me regarding the progress "
strHTMLBody(10) = "of this Invoice. </p><p>Regards</FONT></b></p>"
strHTMLBody(11) = "<p><b><font size=+1><span style='BACKGROUND-COLOR: #ffff00'>Ali Meshkot."
strHTMLBody(12) = "</span></font> </b></p>"
strHTMLBody(13) = ""
strHTMLBody(14) = ""
strHTMLBody(15) = ""
strHTMLBody(16) = ""
strHTMLBody(17) = ""
strHTMLBody(18) = ""
strHTMLBody(19) = ""
strHTMLBody(20) = ""
strHTMLBody(21) = ""
strHTMLBody(22) = ""
strHTMLBody(23) = ""
strHTMLBody(24) = "---------- Your Request----------</b></p></span>"
strHTMLBody(25) = "<pre>"
strHTMLBody(26) = ""
strHTMLBody(27) = ""
strHTMLBody(28) = ""
strHTMLBody(29) = ""
strHTMLBody(30) = "</BODY></HTML>"
strHTMLBody(31) = ""
strHTMLBody(32) = ""
strHTMLBody(33) = ""
intEmailCounter = 1
Sheets("AppliedTo").Activate
' Move to the title column, which is marked
Range("C2").Select
' Find the last cell in this column
LastRowAddress = Selection.End(xlDown).Address
' Find the differently highlighted cells in Column B
For Each CellObject In Range("B1:" & LastRowAddress)
If (CellObject.Interior.ColorIndex = 44) _
And (intEmailCounter <= 6) Then
Set objSalesEmail(intEmailCounter) = objOL.CreateItem(olMailItem)
strEmailBody = ""
' Reset strings 6 and 29 in case the last run was aborted
strHTMLBody(6) = "<p><b><font size=+1><span style='BACKGROUND-COLOR: #ffff00'>Dear "
strHTMLBody(29) = ""
CellObject.Activate
' Move to the second col of this row
strSalesLine(1) = "Type: " & ActiveCell.Offset(0, -1).Value
strSalesLine(2) = "Title: " & ActiveCell.Offset(0, 0).Value
objSalesEmail(intEmailCounter).Subject = _
ActiveCell.Offset(0, 0).Value
strSalesLine(3) = "Service Details: " & ActiveCell.Offset(0, 1).Value
' Break the length of the Details line to 80 col.
strSalesLine(4) = "Location: " & ActiveCell.Offset(0, 2).Value
strSalesLine(5) = "Start: " & ActiveCell.Offset(0, 3).Value
strSalesLine(6) = "Duration: " & ActiveCell.Offset(0, 4).Value
strSalesLine(7) = "Pay: " & ActiveCell.Offset(0, 5).Value
strSalesLine(8) = "Agency: " & ActiveCell.Offset(0, 6).Value
strSalesLine(9) = "Contact: " & ActiveCell.Offset(0, 7).Value
strEmailTo = ActiveCell.Offset(0, 7).Value
strSalesLine(10) = "Tel: " & ActiveCell.Offset(0, 8).Value
strSalesLine(11) = "Fax: " & ActiveCell.Offset(0, 9).Value
strEmailAddress = ActiveCell.Offset(0, 10).Value
If Len(strEmailAddress) > 5 Then ' 5= minimum email address length
strSalesLine(12) = "Email: " & strEmailAddress
objSalesEmail(intEmailCounter).Recipients.Add (strEmailAddress)
Else
MsgReply = MsgBox("Sales at row " _
& ActiveCell.Offset(0, 10).Row _
& " Does not have an email address" & vbCrLf _
& " Will mark and continue", vbOKOnly, "No Email Address")
objSalesEmail(intEmailCounter).Delete
ActiveCell.Interior.ColorIndex = 7
GoTo NextCellObject
End If
strSalesLine(13) = "Web: " & ActiveCell.Offset(0, 11).Value
strSalesLine(14) = "Reference " & ActiveCell.Offset(0, 12).Value
objSalesEmail(intEmailCounter).Subject = _
"Invoice for: " _
& objSalesEmail(intEmailCounter).Subject _
& " - " & strSalesLine(14)
' The Sales details is the sum of the Sales lines
strSalesDetail = ""
For intCounter = 1 To 14
strSalesDetail = strSalesDetail & strSalesLine(intCounter) & NewLine
Next
strSalesDetail = strSalesDetail & "<br></pre></p>"
' Add the email recipient name and Sales details
strHTMLBody(6) = strHTMLBody(6) & strEmailTo
strHTMLBody(29) = strHTMLBody(29) & strSalesDetail
' Now create the email body
For intCounter = 1 To 50
strEmailBody = strEmailBody & strHTMLBody(intCounter)
Next
objSalesEmail(intEmailCounter).Body = ""
objSalesEmail(intEmailCounter).HTMLBody = ""
objSalesEmail(intEmailCounter).HTMLBody = strEmailBody
' Add the attachment
objSalesEmail(intEmailCounter).Attachments.Add (EmailAttachment)
objSalesEmail(intEmailCounter).Categories = "MAM750 Sales Search"
objSalesEmail(intEmailCounter).Display
' This line causes an error, therefore use an array variable objSalesEmail = Nothing
CellObject.Interior.ColorIndex = 6
intEmailCounter = intEmailCounter + 1
End If
NextCellObject:
Next
End Sub
' To send follow-up emails for those Sales that have a follow-up date
' The follow-up date is set by default to 2 days after the Invoice
' date shown on the AppliedTo worksheet.
' The selection criteria is the colour of the new FollowUp column.
' Which must be Orange to send the follow-up email.
' During the email sending process, the colour is reset to indicate
' that the follow-up has been sent.
' The method is:
' 1. Find rows of Sales details with orange colour in the title.
' 2. Create email details from that row.
'
Dim CellObject, LastRowAddress, DateApplied
Dim strSalesLine(1 To 50) As String
Dim strHTMLBody(1 To 100) As String
Dim strSalesDetail As String
Dim strEmailBody As String
Dim strEmailSubject As String
Dim strEmailAddress As String
Dim strEmailTo As String
Dim strAboutCV As String
Const Para = vbCrLf + vbCrLf
Const NewLine = vbCrLf
Const HTMLBreak = "<br>"
Const EmailAttachment = "\\Data2002A\Sales2002\Ali Meshkot.htm"
Dim intCounter As Integer
Dim MsgReply
Dim objNS, objInBox
Dim objFollowUpEmail(1 To 10) ' Number of emails at a time
Dim objOL As Outlook.Application
Dim intEmailCounter As Integer
Set objOL = New Outlook.Application
Set objNS = objOL.GetNameSpace("MAPI")
Set objInBox = objNS.GetDefaultFolder(olFolderInbox)
' Define HTML Body for Email
strHTMLBody(1) = "<HTML><HEAD>"
strHTMLBody(2) = "<TITLE>Follow-up Email from the Accounts Manager Ali Meshkot</TITLE>"
strHTMLBody(3) = "<META http-equiv=Content-Type content='text/html; charset=utf-8'></HEAD>"
strHTMLBody(4) = "<BODY bgColor=#99ffcc LeftMargin=50>"
strHTMLBody(5) = "<BASEFONT='4'></basefont>"
strHTMLBody(6) = "<p><b><font size=+1><span style='BACKGROUND-COLOR: #ffcccc'>Dear "
strHTMLBody(7) = "</span> </b></p>"
strHTMLBody(8) = "<p><b>I sent you an email regarding the above invoice on "
strHTMLBody(9) = ", with my contact details enclosed.  However, I have not received any feedback "
strHTMLBody(10) = "from you yet. Please let me know the current state of this Invoice. </p><p>Regards</FONT></b></p>"
strHTMLBody(11) = "<p><b><font size=+1><span style='BACKGROUND-COLOR: #ffcccc'>Ali Meshkot."
strHTMLBody(12) = "</span></font> </b></p>"
strHTMLBody(13) = ""
strHTMLBody(14) = ""
strHTMLBody(15) = ""
strHTMLBody(16) = ""
strHTMLBody(17) = ""
strHTMLBody(18) = ""
strHTMLBody(19) = ""
strHTMLBody(20) = ""
strHTMLBody(21) = ""
strHTMLBody(22) = ""
strHTMLBody(23) = ""
strHTMLBody(24) = ""
strHTMLBody(25) = ""
strHTMLBody(26) = ""
strHTMLBody(27) = ""
strHTMLBody(28) = ""
strHTMLBody(29) = ""
strHTMLBody(30) = "</BODY></HTML>"
strHTMLBody(31) = ""
strHTMLBody(32) = ""
strHTMLBody(33) = ""
intEmailCounter = 1
Sheets("AppliedTo").Activate
' Move to the title column, which is not to contain any breaks.
Range("C2").Select
' Find the last cell in this column and offset to column Q
LastRowAddress = Selection.End(xlDown).Offset(0, 14).Address
' Find the differently highlighted cells in Column Q
For Each CellObject In Range("Q2:" & LastRowAddress)
If (CellObject.Interior.ColorIndex = 38) _
And (intEmailCounter <= 6) _
And CellObject.Value <= Date Then
Set objFollowUpEmail(intEmailCounter) = objOL.CreateItem(olMailItem)
strEmailBody = ""
' Reset strings 6 and 8 in case the last run was aborted
strHTMLBody(6) = "<p><b><font size=+1><span style='BACKGROUND-COLOR: #ffcccc'>Dear "
strHTMLBody(8) = "<p><b>I sent you an email regarding the above invoice on "
CellObject.Activate
DateApplied = Int(ActiveCell.Offset(0, -16).Value)
' Move to the second col of this row
strSalesLine(1) = "Type: " & ActiveCell.Offset(0, -15).Value
strSalesLine(2) = "Title: " & ActiveCell.Offset(0, -14).Value
objFollowUpEmail(intEmailCounter).Subject = _
ActiveCell.Offset(0, -14).Value
strSalesLine(3) = "Service Details: " & ActiveCell.Offset(0, -13).Value
' Break the length of the Details line to 80 col.
strSalesLine(4) = "Location: " & ActiveCell.Offset(0, -12).Value
strSalesLine(5) = "Start: " & ActiveCell.Offset(0, -11).Value
strSalesLine(6) = "Duration: " & ActiveCell.Offset(0, -10).Value
strSalesLine(7) = "Pay: " & ActiveCell.Offset(0, -9).Value
strSalesLine(8) = "Agency: " & ActiveCell.Offset(0, -8).Value
strSalesLine(9) = "Contact: " & ActiveCell.Offset(0, -7).Value
strEmailTo = ActiveCell.Offset(0, -7).Value
strSalesLine(10) = "Tel: " & ActiveCell.Offset(0, -6).Value
strSalesLine(11) = "Fax: " & ActiveCell.Offset(0, -5).Value
strEmailAddress = ActiveCell.Offset(0, -4).Value
If Len(strEmailAddress) > 5 Then ' 5= minimum email address length
strSalesLine(12) = "Email: " & strEmailAddress
objFollowUpEmail(intEmailCounter).Recipients.Add (strEmailAddress)
Else
MsgReply = MsgBox("Sales at row " _
& ActiveCell.Offset(0, -4).Row _
& " Does not have an email address" & vbCrLf _
& " Will mark and continue", vbOKOnly, "No Email Address")
objFollowUpEmail(intEmailCounter).Delete
ActiveCell.Interior.ColorIndex = 15
GoTo NextCellObject
End If
strSalesLine(13) = "Web: " & ActiveCell.Offset(0, -3).Value
strSalesLine(14) = "Reference " & ActiveCell.Offset(0, -2).Value
objFollowUpEmail(intEmailCounter).Subject = _
"Follow-up for: " _
& objFollowUpEmail(intEmailCounter).Subject _
& " - " & strSalesLine(14)
strHTMLBody(6) = strHTMLBody(6) & strEmailTo
strHTMLBody(8) = strHTMLBody(8) & DateApplied
' Now create the email body
For intCounter = 1 To 50
strEmailBody = strEmailBody & strHTMLBody(intCounter)
Next
objFollowUpEmail(intEmailCounter).Body = ""
objFollowUpEmail(intEmailCounter).HTMLBody = ""
objFollowUpEmail(intEmailCounter).HTMLBody = strEmailBody
objFollowUpEmail(intEmailCounter).Categories = "MAM750 Sales Search"
objFollowUpEmail(intEmailCounter).Display
' This line causes an error, therefore use an array variable objSalesEmail = Nothing
CellObject.Interior.ColorIndex = 2
intEmailCounter = intEmailCounter + 1
End If
NextCellObject:
Next
End Sub
'
' FilterExcel Macro
' Macro recorded 21/10/2001 by Dr. Meshkot
'
' Error recovery
On Error GoTo ExitError
Sheets(strSalesListToday).Activate
Range("B1").Select
Selection.AutoFilter Field:=2, Criteria1:="=*Excel *", Operator:=xlAnd
ExitNormal:
Exit Sub
ExitError:
End Sub
ActiveSheet.Range("B1").AutoFilter
End Sub
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
End Sub
'
' FilterLondonSales Macro
' Macro recorded 21/10/2001 by Dr. Meshkot
'
'
Worksheets(strSalesListToday).Range("B1").Select
Selection.AutoFilter
Selection.AutoFilter Field:=2, Criteria1:="=*Service*", Operator:=xlAnd, _
Criteria2:="<>*cobol*"
Selection.AutoFilter Field:=4, Criteria1:="=*London*", Operator:=xlAnd
Selection.AutoFilter Field:=7, Criteria1:="=*3*", Operator:=xlAnd
End Sub
'
' ApplyAdvancedFilter1 Macro
' Macro Created 25/10/2001 by Dr. Meshkot
'
If SheetExists(strSalesListToday) Then
Worksheets(strSalesListToday).Activate
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
ActiveSheet.UsedRange.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:= _
Sheets("Filter1").UsedRange, Unique:=False
End If
End Sub
'
' ApplyAdvancedFilter1 Macro
' Macro Created 25/10/2001 by Dr. Meshkot
'
If SheetExists(strSalesListPrev) Then
Worksheets(strSalesListPrev).Activate
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
ActiveSheet.UsedRange.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:= _
Sheets("Filter1").UsedRange, Unique:=False
End If
End Sub
'
' ApplyAdvancedFilter1 Macro
' Macro Created 25/10/2001 by Dr. Meshkot
'
If SheetExists(strSalesListToday) Then
Worksheets(strSalesListToday).Activate
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
ActiveSheet.UsedRange.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:= _
Sheets("Filter2").UsedRange, Unique:=False
End If
End Sub
'
' ApplyAdvancedFilter1 Macro
' Macro Created 25/10/2001 by Dr. Meshkot
'
If SheetExists(strSalesListToday) Then
Worksheets(strSalesListToday).Activate
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
ActiveSheet.UsedRange.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:= _
Sheets("Filter3").UsedRange, Unique:=False
End If
End Sub
' To Mark new Sales from the previous Sales file download
' If there is already a Sales list, then get the previous Sales file to compare with.
Dim LookupResult As Variant
Dim OldSalesReference As Variant
Dim NewSalesReference As Variant
Dim OldSalesFlag As Boolean
Dim LookinTable As Range
Dim SalesReferences As Variant
Dim NewSalesCount As Long
' Check to see that we have 2 Sales lists imported.
If SheetExists(strSalesListToday) Then
If SheetExists(strSalesListPrev) Then
GoTo Have2Lists
Else
ImportSalesFile (strSalesListPrev)
FormatRawImport (strSalesListPrev)
Have2Lists:
End If
Else
Exit Sub
End If
' Name the old Sales list reference column
Sheets(strSalesListPrev).Activate
Range("N2").Select
' Find the last cell in this column
LastCellInColAddress = Selection.End(xlDown).Address
' Range("N1:" & LastCellInColAddress).Select
ActiveWorkbook.Names.Add _
Name:="SalesListOldReference", _
RefersTo:="=" & ActiveSheet.Name & "!" & "$N$2:" & LastCellInColAddress
' Name the New (Today's) Sales list reference column
Sheets(strSalesListToday).Activate
' Go to the Sales reference column
Range("N2").Select
' Find the last cell in this column
LastCellInColAddress = Selection.End(xlDown).Address
ActiveWorkbook.Names.Add _
Name:="SalesListNewReference", _
RefersTo:="=" & ActiveSheet.Name & "!" & "$N$2:" & LastCellInColAddress
' Find and highlight the new Sales rows by comparing Today's Saleslist References
' with the Previous download.
' 3 Nov 2001
' The following method works very well, but takes too long.
' For Each NewSalesReference In Range(Names("SalesListNewReference"))
' For Each OldSalesReference In Range(Names("SalesListOldReference"))
' Application.StatusBar = "Comparing " & NewSalesReference & " with " & OldSalesReference
' If NewSalesReference = OldSalesReference Then OldSalesFlag = True
' Next OldSalesReference
' If Not OldSalesFlag Then
' ' Mark row as being a new Sales
' NewSalesReference.Select
' Range(Selection, Cells(ActiveCell.Row, 1)).Select
' Selection.Interior.ColorIndex = 35
' End If
' Next NewSalesReference
' NOTE: There is a problem in the next line which results in runtime error 1004:
' Unable to get the Vlookup property of the Worksheetfunction class.
' This function did not work even with the help file example.
' LookupResult = Application.VLookup("JS/IMB/ING/3010/01", _
' Worksheets("SalesListOld").Range("$N$2:$N$6010"), 1, False)
' 3 Nov 2001
' Another method is to use the VLookup worksheet function on the worksheet
' and use its results to mark the Sales row if the Sale is a new Sale
' This method should be faster because the inner loop is eliminated.
' The method is as follows:
Application.ScreenUpdating = False
For Each NewSalesReference In Range(Names("SalesListNewReference"))
NewSalesReference.Activate
' The following IF statement prevents rechecking a cell that is
' already marked as a new Sales ref.
If ActiveCell.Interior.ColorIndex = 35 Then
NewSalesCount = NewSalesCount + 1
GoTo NextNewSalesReference
End If
' Move to the next column and insert a VLOOKUP formula
ActiveCell.Offset(0, 1).Range("A1").Select
Application.StatusBar = "Processing Row " & ActiveCell.Row
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-1],SalesListOldReference,1,0)"
Worksheets(strSalesListToday).Columns("O:O").Calculate
If Application.WorksheetFunction.IsNA(ActiveCell.Value) Then
' Error 2042 means the cell shows "#N/A" which means the Sales reference
' is new. The IsNA function must be used to test for this value.
' Range(Selection, Cells(ActiveCell.Row, 1)).Select
Range(Cells(ActiveCell.Row, 3), Cells(ActiveCell.Row, 3)).Select
Selection.Interior.ColorIndex = 35
NewSalesCount = NewSalesCount + 1
ActiveCell.Offset(0, 12).Range("A1").Select
End If
ActiveCell.Clear
NextNewSalesReference:
Next
Application.ScreenUpdating = True
MsgBox "There were " & NewSalesCount & " New Sales in " _
& ActiveCell.Row & " Rows."
End Sub
' To Mark new Sales from the previous Sales file download by comparing Sales Details
Dim LookupResult As Variant
Dim OldSalesDetails As Variant
Dim NewSalesDetails As Variant
Dim OldSalesFlag As Boolean
Dim LookinTable As Range
Dim SalesReferences As Variant
Dim NewSalesCount As Long
' Check to see that we have 2 Sales lists imported.
If SheetExists(strSalesListToday) Then
If SheetExists(strSalesListPrev) Then
GoTo Have2Lists
Else
ImportSalesFile (strSalesListPrev)
FormatRawImport (strSalesListPrev)
Have2Lists:
End If
Else
Exit Sub
End If
' Name the old Sales list reference column
Sheets(strSalesListPrev).Activate
Range("C2").Select
' Find the last cell in this column
LastCellInColAddress = Selection.End(xlDown).Address
' Range("N1:" & LastCellInColAddress).Select
ActiveWorkbook.Names.Add _
Name:="SalesListOldDetails", _
RefersTo:="=" & ActiveSheet.Name & "!" & "$C$2:" & LastCellInColAddress
' Name the New (Today's) Sales list reference column
Sheets(strSalesListToday).Activate
' Go to the Sales reference column
Range("C2").Select
' Find the last cell in this column
LastCellInColAddress = Selection.End(xlDown).Address
ActiveWorkbook.Names.Add _
Name:="SalesListNewDetails", _
RefersTo:="=" & ActiveSheet.Name & "!" & "$C$2:" & LastCellInColAddress
' Find and highlight the new Sales rows by comparing Today's Saleslist References
' with the Previous download.
' 4 Nov 2001
' The following method works very well, but takes too long.
' In this case I have to use the slow method.
Debug.Print "----------------------------"; Now
Application.ScreenUpdating = True
For Each NewSalesDetails In Range(Names("SalesListNewDetails"))
' On Error Resume Next
For Each OldSalesDetails In Range(Names("SalesListOldDetails"))
Application.StatusBar = "Comparing New Sales Row " _
& NewSalesDetails.Row & " With Old Sales Row " _
& OldSalesDetails.Row
If Left$(NewSalesDetails, 100) = Left$(OldSalesDetails, 100) Then
OldSalesFlag = True
Debug.Print "New Sales Row "; _
NewSalesDetails.Row; _
" is the same as Old Sales Row "; OldSalesDetails.Row
Debug.Print " "; NewSalesDetails; " = "; OldSalesDetails
GoTo MarkNewSales
Else
OldSalesFlag = False
End If
NextOldSalesDetails:
Next OldSalesDetails
MarkNewSales:
On Error GoTo 0
If Not OldSalesFlag Then
' Mark row as being a new Sales
Range(NewSalesDetails.Address).Activate
' Range(Selection, Cells(ActiveCell.Row, 1)).Select
ActiveCell.Interior.ColorIndex = 35
NewSalesCount = NewSalesCount + 1
End If
Next NewSalesDetails
Application.ScreenUpdating = True
MsgBox "There were " & NewSalesCount & " New Sales in " _
& ActiveCell.Row & " Rows."
End Sub
' By: M. A. Meshkot
' 19 December 2001 00:50
' This routine is to clean the downloaded and imported Saleslists
' Clean here means removing rows that do not have a valid Sales reference number.
' Valid Sales references begin with SS.
Dim LastCellRow
If SheetExists(strSheetName) Then
Sheets(strSheetName).Activate
Else
Exit Sub
End If
' Move to the title column, this is taken as the field for which
' all records have a value.
Range("B2").Select
' Find the last cell in this column
' LastCellInColAddress = Selection.End(xlDown).Offset(0, 12).address
LastCellRow = Selection.End(xlDown).Offset(0, 12).Row
' Move to the reference column
Range("N2").Select
' Find the missing or invalid Sales references and delete that row.
' The following method does not work because when a row is deleted
' the cellobject can not be moved back up by one cell.
' As a result, if say 2 rows have missing reference numbers,
' then only the first is deleted. The second is skipped because after
' deletion, the cursor is moved to the next CellObject.
'
' For Each CellObject In Range("N2:" & LastCellInColAddress)
' If (CStr(CellObject.Value) = "") _
' Or (Left(CStr(CellObject.Value), 2) <> "SS") Then
' CellObject.EntireRow.Delete
' End If
' Next
'
' This second solution causes an infinite loop when it gets to the last row.
' While ActiveCell.Row < LastCellRow
' If (CStr(ActiveCell.Value) = "") _
' Or (Left(CStr(ActiveCell.Value), 2) <> "JS") Then
' ActiveCell.EntireRow.Delete
' ActiveCell.Offset(-1, 0).Activate
' End If
' ActiveCell.Offset(1, 0).Activate
' Wend
' Solution 3: Reduce the last row number whenever a row is deleted.
Application.ScreenUpdating = False
While ActiveCell.Row < LastCellRow
If (CStr(ActiveCell.Value) = "") _
Or (Left(CStr(ActiveCell.Value), 2) <> "JS") Then
ActiveCell.EntireRow.Delete
LastCellRow = LastCellRow - 1
ActiveCell.Offset(-1, 0).Activate
End If
ActiveCell.Offset(1, 0).Activate
Wend
Application.ScreenUpdating = True
Range("N2").Select
End Sub
Sub CleanSalesList()
CleanSaleslistMethod (strSalesListToday)
End Sub
Please click on the link below to return to the English Home Page
If you require some further information, Please Contact Me
Copyright © 2001 Dr. M. A. Meshkot
This page was last updated May 2004