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

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
 

Excel Facts

Excel Joke
Why can't spreadsheets drive cars? They crash too often!
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
 
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
 
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
 
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>
 
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?
 
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?
 
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
 
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
 
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
 

Forum statistics

Threads
1,212,938
Messages
6,110,771
Members
448,297
Latest member
cocolasticot50

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top