'ASSUMPTIONS: LISTS ON ACTIVESHEET
Option Explicit
Option Compare Text
Const None = -4142
Const White = 2
Const BriteRed = 3
Const BriteGreen = 4
Const Blue = 5
Const BriteYel = 6
Const Magenta = 7
Const Cyan = 8
Const Darkred = 9
Const DarkGreen = 10
Const LtBlue = 34
Const LtGreen = 35
Const ToolTip = 36
Const Pink = 38
Const Violet = 39
Const Tan = 40
Const Teal = 42
Const LimaBean = 43
Const Pumpkin = 44
Const Orange = 45
Const Wine = 54
Type PhraseAssign
Phrase As String 'the phrase
Color As String 'the keyword
Name As String 'the assignment
End Type
Type KeyAssign
Color As String 'the keyword
Name As String 'the assignee
End Type
Public ProcessRun As Boolean
Private OkToProcess As Boolean
Private LastPhrase As Long
Private LastPhraseAssign As Long
Private LastKeyWord As Long
Private LastKeyAssign As Long
Private ModuleName$
'PhraseCol 1, PhraseAssignCol 2, KeyWordCol 3, KeyAssignCol 4
Private FieldCols(1 To 4) As String
Private PhraseAssignments() As PhraseAssign
Private KeyAssignments() As KeyAssign
Private KeyOrder() As KeyAssign
'ASSUMPTIONS: LISTS ON ACTIVESHEET
Public Sub ProcessAllLists()
On Error GoTo BeSafe
Application.ScreenUpdating = False
ModuleName$ = "ProcessAllLists"
FindColumnHeaders
If OkToProcess Then
FindListExtents
If OkToProcess Then
ProcessKeywords
If OkToProcess Then
ProcessPhrases
End If
End If
End If
If Not OkToProcess Then
MsgBox "Please make corrections."
End If
StepOut
Application.ScreenUpdating = True
Exit Sub
BeSafe:
ErrorHandler
End Sub
'ASSUMPTIONS: LISTS ON ACTIVESHEET
Public Sub UnProcessLists()
Dim i As Integer
Dim Row1$, Row2$
On Error GoTo BeSafe
ModuleName$ = "UnProcessLists"
Row1$ = "2"
Row2$ = CStr(LastPhraseAssign)
Range(FieldCols(2) & Row1$ & ":" & FieldCols(2) & Row2$).ClearFormats
Range(FieldCols(2) & Row1$ & ":" & FieldCols(2) & Row2$).ClearContents
Row2$ = CStr(LastKeyWord)
Range(FieldCols(3) & Row1$ & ":" & FieldCols(3) & Row2$).ClearFormats
Row2$ = CStr(LastKeyAssign)
Range(FieldCols(4) & Row1$ & ":" & FieldCols(4) & Row2$).ClearFormats
StepOut
Exit Sub
BeSafe:
ErrorHandler
End Sub
'ASSUMPTIONS: LISTS ON ACTIVESHEET
'ASSUMPTIONS: Headers on Row 1
Private Sub FindColumnHeaders()
Dim GotField(1 To 4) As Boolean
Dim i, j, LastCol As Integer
Dim FieldNames(1 To 4), TmpCol As String
On Error GoTo BeSafe
ModuleName$ = "FindColumnHeaders"
'Look for similar, give a little leeway to user
FieldNames(1) = "Phrase"
FieldNames(2) = "Assigned"
FieldNames(3) = "Keyword"
FieldNames(4) = "Assignee"
'rely on vbcompiler to init booleans to false
With ActiveSheet
.Range("IV1").Select
Selection.End(xlToLeft).Select
LastCol = Selection.Column
Select Case LastCol
Case Is < 4
MsgBox "You seem to be missing a necessary data column." & vbCrLf & "This worksheet should contain 4 columns with headers." & vbCrLf & "They should be 'Phrases', 'Assigned To', 'Keyword', and 'Assignee' (person name)."
OkToProcess = False
Exit Sub
Case Else
For i = 1 To LastCol
TmpCol = NumToLtr(i)
For j = 1 To 4
If InStr(1, Range(TmpCol & "1").Value, FieldNames(j)) > 0 Then
If GotField(j) = True Then 'uh oh, already had one by that name
MsgBox "It appears there are two columns with similar field names. Please correct."
OkToProcess = False
Exit Sub
Else
FieldCols(j) = TmpCol
GotField(j) = True
Exit For
End If
End If
Next
'loop not worth it
OkToProcess = GotField(1) And GotField(2) And GotField(3) And GotField(4)
If OkToProcess Then Exit For 'take first 4 qualifiers by default
Next
End Select
End With
Exit Sub
BeSafe:
ErrorHandler
End Sub
'ASSUMPTIONS: LISTS ON ACTIVESHEET
Private Sub FindListExtents()
Dim i As Long
Dim Row$
On Error GoTo BeSafe
ModuleName$ = "FindListExtents"
With ActiveSheet
'1 LastPhrase, 2 LastPhraseAssign, 3 LastKeyWord, 4 LastKeyAssign
Range(FieldCols(1) & "65536").Select
Selection.End(xlUp).Select
LastPhrase = Selection.Row
If LastPhrase < 2 Then
MsgBox "There are no phrases to process."
OkToProcess = False
Exit Sub
Else
LastPhraseAssign = Selection.Row
End If
Range(FieldCols(3) & "65536").Select
Selection.End(xlUp).Select
LastKeyWord = Selection.Row
If LastKeyWord < 2 Then
MsgBox "There are no keywords to process."
OkToProcess = False
Exit Sub
End If
Range(FieldCols(4) & "65536").Select
Selection.End(xlUp).Select
LastKeyAssign = Selection.Row
If LastKeyAssign < 2 Then
MsgBox "There is no one assigned to the keywords."
OkToProcess = False
Exit Sub
End If
End With
'normalize
If LastKeyWord > LastKeyAssign Then
LastKeyAssign = LastKeyWord
Else
LastKeyWord = LastKeyAssign
End If
ReDim PhraseAssignments(2 To LastPhrase)
ReDim KeyAssignments(2 To LastKeyWord)
With ActiveSheet
For i = 2 To LastPhrase
Row$ = CStr(i)
'if someone left a blank inside the phrase list
PhraseAssignments(i).Phrase = Trim$(.Range(FieldCols(1) & Row$).Value)
If Len(PhraseAssignments(i).Phrase) = 0 Then
PhraseAssignments(i).Phrase = "???"
End If
Next
For i = 2 To LastKeyWord 'row 1 field names
Row$ = CStr(i)
KeyAssignments(i).Color = Trim$(.Range(FieldCols(3) & Row$).Value)
KeyAssignments(i).Name = Trim$(.Range(FieldCols(4) & Row$).Value)
.Range(FieldCols(3) & Row$).Select
'if someone forgot to put a name with a color or left a blank in the list
If Len(KeyAssignments(i).Color) = 0 Then
KeyAssignments(i).Color = "???"
End If
.Range(FieldCols(4) & Row$).Select
If Len(KeyAssignments(i).Name) = 0 Then
KeyAssignments(i).Name = "???"
End If
Next
End With
'Clean Up Any Prior Processing, unmark cells, clear assigned to list
UnProcessLists
'POSTPROCESS to COLOR FRAMES
With ActiveSheet
For i = 2 To LastKeyWord
Row$ = CStr(i)
If KeyAssignments(i).Color = "???" Then
.Range(FieldCols(3) & Row$).Select
FrameCell Teal
End If
If KeyAssignments(i).Name = "???" Then
.Range(FieldCols(4) & Row$).Select
FrameCell Teal
End If
Next
End With
Exit Sub
BeSafe:
ErrorHandler
End Sub
'ASSUMPTIONS: LISTS ON ACTIVESHEET
Private Sub ProcessKeywords()
Dim OrderChanged As Boolean
Dim i, j, k, Longest, TmpLen1, TmpLen2, TmpOrder1 As Integer
Dim Order() As Integer
'CREATE ORDERED LIST OF LONGEST COLOR NAME TO SHORTEST COLOR NAME
'USED TO LOCATE CORRECT COLORNAME IN PHRASE WHEN TWO OR MORE COLOR NAMES
'HAVE THE SAME SUB PARTS LIKE BLUE AND BLUEGRAY. CHECK FOR BLUEGRAY FIRST
On Error GoTo BeSafe
ModuleName$ = "ProcessKeywords"
OkToProcess = True
ReDim Order(2 To LastKeyWord, 2) As Integer
For i = 2 To LastKeyWord 'current user order
Order(i, 1) = Len(KeyAssignments(i).Color) 'colorname length
Order(i, 2) = i 'current order on list
Next
For i = 2 To UBound(Order)
TmpLen1 = Order(i, 1) 'current length
OrderChanged = False
For j = i To UBound(Order)
TmpLen2 = Order(j, 1) 'next length
If TmpLen2 > TmpLen1 Then
TmpLen1 = TmpLen2
OrderChanged = True
Longest = j 'list pointer
End If
Next
If OrderChanged Then
TmpLen1 = Order(Longest, 1) 'color length
TmpOrder1 = Order(Longest, 2) 'list position pointer
Order(Longest, 1) = Order(i, 1) 'move smaller up to longest
Order(Longest, 2) = Order(i, 2) 'move listpointer with it
Order(i, 1) = TmpLen1 'move longest to beginning
Order(i, 2) = TmpOrder1 'move listpointer with it
End If
Next
ReDim KeyOrder(2 To LastKeyWord)
For i = 2 To LastKeyWord
KeyOrder(i).Color = KeyAssignments(Order(i, 2)).Color
KeyOrder(i).Name = KeyAssignments(Order(i, 2)).Name
Next
Exit Sub
BeSafe:
ErrorHandler
End Sub
'ASSUMPTIONS: LISTS ON ACTIVESHEET
Private Sub ProcessPhrases()
Dim GotColor As Boolean
Dim KeyLen, KeyStart, PhraseLen As Integer
Dim i, j, k As Long
Dim Row$
On Error GoTo BeSafe
ModuleName$ = "ProcessPhrases"
With ActiveSheet
For i = 2 To LastPhrase
Row$ = CStr(i)
GotColor = False
If PhraseAssignments(i).Phrase <> "???" Then
For j = 2 To LastKeyWord
KeyStart = InStr(1, PhraseAssignments(i).Phrase, KeyOrder(j).Color)
If KeyStart > 0 Then
GotColor = True
PhraseAssignments(i).Name = KeyOrder(j).Name
.Range(FieldCols(2) & Row$).Value = PhraseAssignments(i).Name
If PhraseAssignments(i).Name = "???" Then
.Range(FieldCols(2) & Row$).Select
FrameCell DarkGreen
End If
For k = 2 To LastKeyWord
'now check the other colors too...
If k <> j Then
If InStr(1, KeyOrder(j).Color, KeyOrder(k).Color) = 0 Then
'(k)Color isn't a subpart of a longer colorname (j)Color
'so go ahead and test for a second color
If InStr(1, PhraseAssignments(i).Phrase, KeyOrder(k).Color) > 0 Then
'uh oh, two+ colors
.Range(FieldCols(2) & Row$).Select
.Range(FieldCols(2) & Row$).Value = .Range(FieldCols(2) & Row$).Value & " ##"
FrameCell Orange
Exit For
End If
End If
End If
Next
Exit For
End If
Next
'uh oh, no keyword color associated with phrase
If Not GotColor Then
.Range(FieldCols(2) & Row$).Select
.Range(FieldCols(2) & Row$).Value = "???"
FrameCell DarkGreen
End If
Else
'a blank phrase in the list
.Range(FieldCols(2) & Row$).Select
.Range(FieldCols(2) & Row$).Value = "???"
FrameCell DarkGreen
End If
Next
End With
Exit Sub
BeSafe:
ErrorHandler
End Sub
'ASSUMPTIONS: LISTS ON ACTIVESHEET
Private Sub StepOut()
Dim i As Integer
For i = 1 To 256
If Len(Trim(Cells(1, i).Value)) = 0 Then
Cells(1, i).Select
Exit For
End If
Next
End Sub
'ASSUMPTIONS: LISTS ON ACTIVESHEET
Private Sub FrameCell(HiliteColor)
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = HiliteColor
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = HiliteColor
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = HiliteColor
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = HiliteColor
End With
End Sub
'ASSUMPTIONS: LISTS ON ACTIVESHEET
Private Sub UnFrameCell()
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlNone
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlNone
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlNone
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlNone
End With
End Sub
Private Function NumToLtr(Num) As String
Dim Letter1 As Integer, Letter2 As Integer
Letter2 = (Num Mod 26)
Letter1 = Int(Num / 26) + (Letter2 = 0)
Letter2 = -(Letter2 = 0) * 26 + Letter2
If Letter1 > 0 Then
NumToLtr = Chr(Letter1 + 64)
End If
NumToLtr = NumToLtr & Chr(Letter2 + 64)
End Function
Private Sub ErrorHandler()
MsgBox "Processing was interrupted in Module:" & ModuleName$ & vbCrLf & Err.Description
Err.Clear
OkToProcess = False
Application.ScreenUpdating = True
End Sub
