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

[squiresk]

Thanks very much..

I'll will go through it again. I guess the main thing is the array 'elements' begin at zero, not 1.

Kai, (in Austrialia)

[Daniel Ferry]

Kai,

Unless you specifiy otherwise, yes, all array elements will begin at zero.

But let VBA resize the variant for you; no need to do the ReDim yourself unless you really needed the dimensions to begin at different numbers (which you don't).

When I optimize my code I alway look for lines and variables I can eliminate. That's why I spent a moment pointing some out. Less code is usually better.

I'll leave you with another thing to think about. Loops are great, but they can very quickly slow down your code, if there were hundreds or even thousands of elements in the lookup tables. In this exercise it is academic since there are only 10 elements in each.

But for learning purposes, it would be a good thing if you could figure-out a way to eliminate one of the loops or, better yet, both. This can be done, and would be a really great achievement. A clue is that Excel has many wonderful worksheet functions that can be called from VBA (i.e., WorksheetFunctions.Find). With some ingenuity, these can be used in a great many situations to remove loops from VBA code. To be sure, looping is still going on, but it is being done by very fast, compiled C++ code, and not poky interpreted VBA. In a real-world application this can dramatically increase your code execution speed, in some cases from minutes to run a given loop, improved to requiring just a fraction of a second with the method described.

Anyways, happy coding.

Regards,

Daniel

[kmclean01]

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.

[poreilly01]

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//showthr...lter&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]

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.

[Noel Holland]

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.

[indiaravi]

Hi Mr. Jelen
Please look at this Macro in response to your "Challenge of the Month Jun / Jul 2008"
Warm Regards


Sub Macro1()

' Macro recorded 7/4/2008 by INDIARAVI

Dim KWend As Long, i As Long, Phrase As String, KW As String, PhraseEnd As Long, j As Long, WSEnd As Long
WSEnd = Range("A1").End(xlDown).Row + 1
KWend = Range("D" & WSEnd).End(xlUp).Row
PhraseEnd = Range("A" & WSEnd).End(xlUp).Row
For i = 2 To KWend
KW = Range("D" & i).Value
For j = 2 To PhraseEnd
Phrase = Range("A" & j).Value
If InStr(Phrase, KW) > 0 Then
Range("B" & j).Value = Range("E" & i).Value
End If
Next j
Next i
End Sub

[pjzamudio]

This is my first post (golf clap).

I'm currently deployed to the Middle East and I am stuck in a non-flying desk job for a month, so this gives me a great escape until I get back to flying.

The code below also accounts for multiple people assigned to same "color" by concatenating " / " between multiple names. You probably don't need the declarations, but I'm old fashioned.

Sub subParseColor()
Dim iCompareCol As Integer
Dim iCompareRow As Integer
Dim iLookupTableCol As Integer
Dim iLookupTableRow As Integer
Dim strCompare As String
Dim strLookupTable As String
 
iCompareCol = 1
iCompareRow = 2
iLookupTableCol = 4
iLookupTableRow = 2
 
With ActiveSheet
   strCompare = .Cells(iCompareRow, iCompareCol).Value
   strLookupTable = .Cells(iLookupTableRow, iLookupTableCol).Value
   While strCompare <> "" 
      While strLookupTable <> "" 
         If (InStr(1, strCompare, strLookupTable)) Then _
            .Cells(iCompareRow, iCompareCol + 1).Value = _
              IIf(.Cells(iCompareRow, iCompareCol + 1).Value <> "", _
               .Cells(iCompareRow, iCompareCol + 1).Value & " / " & _
               .Cells(iLookupTableRow, iLookupTableCol + 1).Value, _
               .Cells(iLookupTableRow, iLookupTableCol + 1).Value)
         iLookupTableRow = iLookupTableRow + 1
         strLookupTable = .Cells(iLookupTableRow, iLookupTableCol).Value
      Wend
      iLookupTableRow = 2
      strLookupTable = .Cells(iLookupTableRow, iLookupTableCol).Value
      iCompareRow = iCompareRow + 1
      strCompare = .Cells(iCompareRow, iCompareCol).Value
   Wend 
 End With
End Sub

[Fowmy]

1. Make the following Two defined Names (Fm & Key) & enter as an array formula by pressing (Ctrl+Shift+Enter).

FM =INDEX(Sheet1!$D$2:INDIRECT("$E$"&ROWS(Key)+1),MAX(IF(ISERROR(SEARCH(IF(CODE(TRIM(Key))=32,-1,TRIM (Key)),Sheet1!A31)),-2,ROW(Key)-1)),2)

KEY =Sheet1!$D$2:INDIRECT("$d$"&MAX((LEN(Sheet1!$D$2:$D$634)<>0)*ROW(Sheet1!$D$2:$D$634)))

2. Type the following formula in cell b2 & copy down

=IF(ISERROR(Fm),"Color not found!",Fm)

[Derek Brown]

An update to my solution of 9th July, with a change of function name to ReverseVLOOKUP, this includes more argument validation and the option to check the entire content of the cell.

Function ReverseVLOOKUP(rngCell As Range, rngTable As Range, lngColumn As Long, _
    Optional blEntireCellContent As Boolean) As String
Application.Volatile
Dim rng As Range
Dim blEntireCell As Boolean
If ((lngColumn > rngTable.Columns.Count) Or (lngColumn < 1) Or _
    (rngCell.Columns.Count > 1) Or (rngCell.Rows.Count > 1)) Then
    ReverseVLOOKUP = "#REF!"
    Exit Function
End If
If IsMissing(blEntireCellContent) Then
    blEntireCell = False
Else
    blEntireCell = blEntireCellContent
End If
For Each rng In rngTable.Columns(1).Cells
    If blEntireCell Then
        If rngCell.Value = rng.Value Then
            ReverseVLOOKUP = Cells(rng.Row, rng.Column + lngColumn - 1)
            Exit For
        End If
    ElseIf InStr(1, rngCell.Value, rng.Value) > 0 Then
        ReverseVLOOKUP = Cells(rng.Row, rng.Column + lngColumn - 1)
        Exit For
    End If
Next rng
Set rng = Nothing
End Function

The first argument is the lookup value, the second is the table array, the third is the column to return and the new argument is a boolean (true or false) to indicate whether the entire cell is to match.