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

[bridgesm]

Re: June/July 2008 Challenge of the Month

I know I'm a few months too late, but I just checked the board for the first time in ages (I was bored). I had a go, and then saw everyone else's entries. But here's my sorrt attempt:

Sub theChallenge()

Dim countKeywords As Integer
Dim countPhrases As Integer

Dim i As Integer
Dim j As Integer

Dim theWords
Dim thePhrases

countKeywords = Range(Cells(2, 4), Cells(2, 4).End(xlDown)).Rows.count
countPhrases = Range(Cells(2, 1), Cells(2, 1).End(xlDown)).Rows.count

ReDim theWords(countKeywords, 2) As Variant
ReDim thePhrases(countPhrases) As String

Worksheets("Sheet1").Select

For i = 1 To countPhrases
thePhrases(i) = Cells(i + 1, 1)
Next i

For i = 1 To countKeywords
For j = 1 To 2

theWords(i, j) = Cells(i + 1, j + 3)

Next j
Next i


For i = 1 To countPhrases
For j = 1 To countKeywords
If InStr(1, thePhrases(i), theWords(j, 1), 1) > 0 Then
Cells(i + 1, 2) = theWords(j, 2)
End If
Next j
Next i

End Sub

 

[Bidyut_Saha]

Re: June/July 2008 Challenge of the Month

Sub RoundedRectangle1_Click()

Dim r1 As Range, r2 As Range
Worksheets("Sheet1").Activate
Set r1 = Range("A2:B25")
Set r2 = Range("D2:E10")

Dim i As Integer, j As Integer
For i = 1 To 24
For j = 1 To 9
If InStrRev(r1.Cells(i, 1).Value, r2.Cells(j, 1).Value) > 0 Then
r1.Cells(i, 2).Value = r2(j, 2).Value
End If
Next
Next

End Sub

 

[KaranVBExpert]

Re: June/July 2008 Challenge of the Month

I think I am a little late in submitting the solution to the challenge. But, better late than never.

Hoping to solve tougher challenges in future

Sub mrexcelchallengejuly()

Dim lastrowcolmnA As Integer
Dim lastrowcolmnD As Integer

lastrowcolmnA = ActiveSheet.Range("A65536").End(xlUp).Row
lastrowcolmnD = ActiveSheet.Range("D65536").End(xlUp).Row

For j = 2 To lastrowcolmnA
If Cells(j, 1).Value <> "" Then
For i = 2 To lastrowcolmnD
If Cells(i, 4).Value <> "" Then
If InStr(1, Cells(j, 1).Value, Cells(i, 4).Value, vbTextCompare) > 0 Then
Cells(j, 2).Value = Cells(i, 5).Value
End If
End If
Next
End If
Next

MsgBox ("Process completed. " & Chr(10) & Chr(10) & "Please send me my prize ")

End Sub

 

[edttoma]

Re: June/July 2008 Challenge of the Month

A late suggestion...

Function Assigned(sColourful As String, AssignColourTo As Range) As String
'This function handles several colours (you never know)
'Try "Rainbow red orange yellow green blue indigo green magenta purple"!
'Formula e.g.: =Assigned(A2;$D2$:$E10)
Dim sSplit As Variant
On Error Resume Next
'Remove charcter (160) and loop over all words in the text
For Each sSplit In Split(Replace(sColourful, Chr(160), ""))
'Use the VLOOKUP workhorse...and append the persons to the function
Assigned = Assigned & " " & WorksheetFunction.VLookup(sSplit, AssignColourTo, 2, False)
Next sSplit
End Function

 

[jules1970]

Re: June/July 2008 Challenge of the Month

Just a little late, but wanted to share my approach:
Implementing regular expressions in VBA:

Private Function RegExpMatch(ByVal Cadena As String, ByVal PatronBusqueda As String, Optional IgnorarMayusculaMinuscula As Boolean = True, Optional Multilinea As Boolean = False) As String()

Dim re As New RegExp
Dim mMatches As MatchCollection
Dim mMatch As Match
Dim resultados() As String
Dim i As Integer

re.Pattern = PatronBusqueda
re.Global = True
re.IgnoreCase = IgnorarMayusculaMinuscula
re.MultiLine = Multilinea

Set mMatches = re.Execute(Cadena)
If mMatches.Count > 0 Then
ReDim resultados(0 To mMatches.Count - 1)
For i = 0 To mMatches.Count - 1
resultados(i) = mMatches(i).Value
Next
RegExpMatch = resultados
Else
ReDim resultados(-1 To -1)
resultados(-1) = ""
RegExpMatch = resultados
End If

End Function

Public Function RegExpEncontrar( _
ByVal Cadena As String, _
ByVal PatronBusqueda As String, _
Optional NumeroCoincidencia As Integer = 1, _
Optional IgnorarMayusculaMinuscula As Boolean = True, _
Optional Multilinea As Boolean = False) As String

Dim resultados() As String
Dim i As Integer
resultados = RegExpMatch(Cadena, PatronBusqueda, IgnorarMayusculaMinuscula, Multilinea)
i = NumeroCoincidencia - 1
If i >= 0 And i <= UBound(resultados) Then
RegExpEncontrar = resultados(i)
Else
RegExpEncontrar = ""
End If

End Function

The solution is quite easy

Cell E12=blue|red|yellow|pink
Formula= =regexpencontrar(A2,$E$12)

Will return the text that matches the pattern.


<table style="border-collapse: collapse; width: 270pt;" width="359" border="0" cellpadding="0" cellspacing="0"><col style="width: 130pt;" width="173"> <col style="width: 140pt;" width="186"> <tbody><tr style="height: 15pt;" height="20"> <td style="height: 15pt; width: 130pt;" width="173" height="20">Phrase</td> <td style="width: 140pt;" width="186">Assigned</td> </tr> <tr style="height: 15pt;" height="20"> <td style="height: 15pt;" height="20">the ocean is blue</td> <td>blue</td> </tr> <tr style="height: 15pt;" height="20"> <td style="height: 15pt;" height="20">I like his blue shirt</td> <td>blue</td> </tr> </tbody></table>
And then using the value to lookup in the table:

=VLOOKUP(B2,$E$2:$F$5,2,FALSE)

And it's done! To enhance the search, just modify the pattern and voalá!!!

Thanks
Julio
<table style="border-collapse: collapse; width: 48pt;" width="64" border="0" cellpadding="0" cellspacing="0"><col style="width: 48pt;" width="64"><tbody><tr style="height: 15pt;" height="20"> <td style="height: 15pt; width: 48pt;" width="64" height="20">
</td> </tr></tbody></table>

 

[andrewman]

Re: June/July 2008 Challenge of the Month

I've posted a new challenge of the month today. Like the last challenge, this one will have many different approaches. Post your entries here. While the ultimate "best" entry wins the LiveLessons DVD, several podcast DVD's are available to anyone who proposes a significant advancement towards a cool solution.

Entries are due by 15 July 2008.

Bill Jelen

When we have the result for June/July 2008 Challenge?

 

[Jonmo1]

Re: June/July 2008 Challenge of the Month

Seriously, here we are in October. I'm actually curious, this is the first challenge I've participated in. When/How will we know who wins? And when might there be a new challenge?

 

[stanleydgromjr]

Re: June/July 2008 Challenge of the Month

When/How will we know who wins? And when might there be a new challenge?


Have a great day,
Stan

 

[gavinkelly]

Re: June/July 2008 Challenge of the Month

I think a name change is in order, perhaps "Challenge once in a blue moon".

Come on pick a winner and make a new challenge please

 

[Randombard]

Re: June/July 2008 Challenge of the Month

I know that the primary driving aspect of this formula has already been posted,

I have just added to it to make it more versatile.

=IF(ISERROR(LOOKUP(2^15,SEARCH(D$2:D$10,A2),E$2:E$10)),"Not In List",LOOKUP(2^15,SEARCH(D$2:D$10,A2),E$2:E$10))

In no way can I take credit for the clever part of this formula, I just noticed that on those occations that the word in A1 was not in the lookup vector I got #N/A