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

[kmclean01]

Re: June/July 2008 Challenge of the Month

Here is my (very long) VBA solution...sorry I am still pretty new to VBA (trying to teach myself):

Sub finding()
    Dim rFound As Range
    counter = 1
    'Determine how many Phrases there are in the range
    textcountp = WorksheetFunction.CountA(Range("a:a")) - 1
    'Determine how many Keywords there are in the range
    textcountK = WorksheetFunction.CountA(Range("d:d")) - 1
    With Application.FindFormat.Font
        .Subscript = False
        .ColorIndex = xlAutomatic
    End With
    'Loops until you have gone through all of the keywords
    Do Until counter2 = textcountK
        'Loops until you have gone through all of the phrases
        Do Until counter = textcountp + 1
            On Error Resume Next
            Range("a2:a" & textcountp + 1).Select
            With Sheet1
                'Finds the keyword
                Set rFound = Range("a2:a" & textcountp + 1).Find(What:=Cells(2 + counter3, 4), After:=ActiveCell, LookIn:=xlFormulas, _
                    LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                    MatchCase:=False, SearchFormat:=True).Activate
                If counter > 1 Then
                    'Finds the keyword again
                    Do Until again = counter
                       Selection.FindNext(After:=ActiveCell).Activate
                        If again = 0 Then
                            again = again + 2
                        Else
                        again = again + 1
                        End If
                    Loop
                End If
                counter = counter + 1
                ActiveCell.Offset(0, 1).Select
                'Copies the keyword if the cell is empty
                If ActiveCell.Value = Empty Then
                    Cells(2 + counter3, 5).Copy
                    ActiveSheet.Paste
                End If
                If again = 0 Then
                Else
                    again = 1
                End If
            On Error GoTo 0
                If Not rFound Is Nothing Then Application.Goto rFound, True
            End With
        Loop
        counter2 = counter2 + 1
        counter3 = counter3 + 1
        counter = 1
    Loop
End Sub

I will say, that I enjoyed trying to figure this out.

 

[Gene Khalyapin]

Re: June/July 2008 Challenge of the Month

Here's one possibility.....

=LOOKUP(2^15,SEARCH(D$2:D$10,A2),E$2:E$10)

Very impressive! I did not know this function can be used this way.

I just found this challenge and wanted to come up with my own solution for this problem (it's always exciting to work on a challenging problem).
This is the first solution I came up with:
=INDEX($E$2:$E$10,SUM(IF(IF(ISERROR(FIND($D$2:$D$10,REPT(A2,ROWS($D$2:$D$10)))),0,1)=1,ROW($E$2:$E$10)-1,0)))

Array formula: Ctrl+Shift+Enter

I used REPT function (later I figured I could have used SUMPRODUCT + FIND to get the same results).

 

[poreilly01]

Re: June/July 2008 Challenge of the Month

This is my 1st post so I am not sure where things go.

There is so much code on the internet it seems futile to reinvent the wheel so I have used some VB script from Dave Hawley at Ozgrid
http://www.ozgrid.com/forum//showthread.php?t=61347&do=filter&fid=32201
and added one extra line to stop it running past the last non-balnk field (If rFound = "" Then Exit Sub) .

My solution goes -

run the macro "FindText" and it will provide a column (col B "Colour") containing the extracted colours contained in the adjacent text. Once you have a single word you can easily use vlookup.

Column A is named "FindRange" instead of "Phrases" & is the "FindRange" refered to in the macro & can be any length, no blanks in the list.

Column B named "Colour", is a list of colours returned by the macro to enable the vlookup to be performed.

Column C named "Assigned to" (original moved one column right) contains a vlookup to assign a name to each colour.

Column D is not used.

Column E & F have been reversed & are the original "Assigned to" & "Keyword" columns. "Keyword" is now a named range named "LookRange" to match the name in the macro for clarity & now has the column heading of "LookRange". It can be any length.

Columns C & G contain formulae & need to be dragged to the bottom of the corresponding list adjacent if extra rows are added.

When the macro runs all cells are populated with the answers.

Column G headed "No of Ea" is an extra I used to check the result. It totals the number of occurances of each keyword assigned to each name.

macro Code:

Sub FindText()
Dim rCell As Range, rFindIn As Range
Dim strWord As String, lLoop As Long
Dim rFound As Range

Set rFindIn = Range("FindRange")

For Each rCell In Range("LookRange")

strWord = rCell
Set rFound = rFindIn.Cells(1, 1)

For lLoop = 1 To WorksheetFunction.CountIf(rFindIn, "*" & strWord & "*")

Set rFound = rFindIn.Find(What:=strWord, After:=rFound, LookIn:=xlValues, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False)

rFound(1, 2) = strWord

If rFound = "" Then Exit Sub
Next lLoop

Next rCell

End Sub


Column C Vlookup for the "assigned to" names -
=VLOOKUP(B2,$E$1:$F$11,2,FALSE)

Column G formula used to count the occurances for each name -
=IF(COUNTIF(B:B,LookRange)=0,"None",COUNTIF(B:B,LookRange))

 

[poreilly01]

Re: June/July 2008 Challenge of the Month

My vlookup

Column C Vlookup for the "assigned to" names -
=VLOOKUP(B2,$E$1:$F$11,2,FALSE)

should have been =VLOOKUP(B2,E:F,2,FALSE)

this will extend to the end of the the columns so you can have as many entries as you like.

 

[parmel]

Re: June/July 2008 Challenge of the Month

Here's a macro that uses AutoFilter. Sorry for the lack of indentation - I haven't posted to the board for a long time and I've forgotten how to mark a code block.

Sub assign_colors()
Dim rColors As Range
Dim c1 As Range
Dim c2 As Range
Dim rPhrases As Range
Dim sCriteria As String

Application.ScreenUpdating = False
Set rColors = Range(Cells(2, 4), Cells(2, 4).End(xlDown))
Set rPhrases = Range(Cells(1, 1), Cells(1, 1).End(xlDown))

For Each c1 In rColors 'loop through the colors
sCriteria = "=*" & c1.Value & "*"
rPhrases.AutoFilter Field:=1, Criteria1:=sCriteria
For Each c2 In rPhrases 'assign the color to the phrase
If c2.EntireRow.Hidden = False Then
c2.Offset(0, 1).Value = c1.Offset(0, 1).Value
End If
Next c2
Next c1

'turn off autofilter
rPhrases.AutoFilter
Application.ScreenUpdating = True
End Sub

 

[parmel]

Re: June/July 2008 Challenge of the Month

Here's a macro that uses AutoFilter. I'm sorry for the lack of indentation. I've forgotten how to denote a code block.

Sub assign_colors()
Dim rColors As Range
Dim c1 As Range
Dim c2 As Range
Dim rPhrases As Range
Dim sCriteria As String

Application.ScreenUpdating = False
Set rColors = Range(Cells(2, 4), Cells(2, 4).End(xlDown))
Set rPhrases = Range(Cells(1, 1), Cells(1, 1).End(xlDown))

For Each c1 In rColors 'loop through the colors
sCriteria = "=*" & c1.Value & "*"
rPhrases.AutoFilter Field:=1, Criteria1:=sCriteria
For Each c2 In rPhrases 'assign the color to the phrase
If c2.EntireRow.Hidden = False Then
c2.Offset(0, 1).Value = c1.Offset(0, 1).Value
End If
Next c2
Next c1

'turn off autofilter
rPhrases.AutoFilter
Application.ScreenUpdating = True
End Sub

 

[gavinkelly]

Re: June/July 2008 Challenge of the Month

Another UDF:

Function ContainsText(Rng As Range, Text As String, Rng2 As Range) As String
'rng is first column of colours, text is the phrase, rng2 is second column of assigned values

n = 1
Dim myCell As Range
For Each myCell In Rng 'look in each cell

    If 0 < InStr(Text, myCell) Then
        ContainsText = Rng2(n)
        Exit For
    End If
n = n + 1
Next myCell

End Function

i will make it so that only one rng is required when i figure out how

 

[gavinkelly]

Re: June/July 2008 Challenge of the Month

Final version:

Function ContainsText2(Rng As Range, Text As String) As String
'rng is table-i.e. in this example D2:E10, text is phrase

n = 1
For x = 1 To Rng.Count / 2    ' only works if 2 columns in rng
    If 0 < InStr(Text, Rng(n, 1)) Then
        ContainsText2 = Rng(n, 2)
        Exit For
    End If
n = n + 1
Next x

End Function

 

[gavinkelly]

Re: June/July 2008 Challenge of the Month

Ok i believe this is my improved code.
i have included KeyWordCol & AssignedCol as optional arguments so anysize table can be used for the lookup and the order of the columns does not matter either.

Function ContainsText(Rng As Range, Phrase As String, Optional KeyWordCol As Integer = 1, Optional AssignedCol As Integer = 2) As String

n = 1
For x = 1 To Rng.Rows.Count
    If 0 < InStr(Phrase, Rng(n, KeyWordCol)) Then
        ContainsText = Rng(n, AssignedCol)
        Exit For
    End If
n = n + 1
Next x

End Function

 

[Noel Holland]

Re: June/July 2008 Challenge of the Month

I added a column of sequential numbers in column C to act as a Key Reference number, then:

=VLOOKUP(SUMPRODUCT(NOT(ISERROR(SEARCH($D$2:$D$10,A2,1)))*($C$2:$C$10)),$C$2:$E$10,3,0)


Still getting my head round that solution from barry above. That is a seriously streamlined solution. Going to be interested in hearing how it works.