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

Public Sub Keyword_Assign()
        Set Phrases = Worksheets("sheet1").Range("A1:A10000")
         No_keys = Range("d1").CurrentRegion.Rows.Count - 1
         ReDim Keys(No_keys, 2)
      For n = 1 To No_keys
            Keys(n, 1) = Cells(n + 1, 4)
            Keys(n, 2) = Cells(n + 1, 5)
      Next n
' Cycle through Keywords, get next keyword text string to be searched
    For i = 1 To No_keys
            Target = Cells(i + 1, 4)
            Assignee = Cells(i + 1, 5)
            'Search the phrase range for target using Find
                Set T_Cells = Phrases.Find(What:=Target, _
                    After:=Phrases.Cells(Phrases.Cells.Count), _
                    LookIn:=xlFormulas, LookAt:=xlPart, _
                    SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                    MatchCase:=False)
           ' Check to see if anything found, if no, increment For/Next     ​
                If T_Cells Is Nothing Then GoTo 99
                Application.Goto reference:=T_Cells
            Do
              'Loop through T_Cells until last entry found
               Set T_found_cell = T_Cells
              Set T_Cells = Phrases.FindNext(After:=T_found_cell)
              rw = T_Cells.Row
             Cells(rw, 2) = Keys(i, 2)
             If T_found_cell.Row >= T_Cells.Row Then Exit Do
           Loop
         99
   Next i
End Sub

Private Sub CommandButton1_Click()
Dim rng As Range
Set rng = Range("A2:A25")


For Each Value In rng
x = 2
Do Until x = 10
Col = Cells(x, 4).Value
myint = InStr(1, Value, Col)
If myint > 0 Then
If Value.Offset(0, 1).Value <> 0 Then
Value.Offset(0, 1).Value = Value.Offset(0, 1).Value & ", " & Cells(x, 5).Value
Else
Value.Offset(0, 1).Value = Cells(x, 5).Value
End If
End If
x = x + 1

Loop
Next Value

End Sub