***WINNERS ANNOUNCEMENT*** June/July 2008 Challenge of the Month

Public Function AssignTo(Phrase As Range, KeywordsRange As Range) As String

Dim vKeyword As Variant
Dim vCheck As Variant

    For Each vKeyword In KeywordsRange
        vCheck = InStr(Phrase, vKeyword.Value)
        If vCheck > 0 Then
            AssignTo = vKeyword.Offset(0, 1).Value
            Exit Function
        End If
    Next vKeyword

End Function

'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

Option Explicit
Option Compare Text

Private Sub ProcessLists_Click()
  ProcessAllLists
  ProcessRun = True
  Application.ScreenUpdating = True 'just in case
End Sub

Private Sub Reset_Click()
  If ProcessRun Then
    UnProcessLists
    ProcessRun = False
  Else
    'have to setup arrays first
    MsgBox "Please run Process Lists first...."
  End If
  Application.ScreenUpdating = True 'necessary
End Sub