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

Re: June/July 2008 Challenge of the Month

This is the best I could manage

=OFFSET(E1,MATCH(1,IF(SEARCH(D2:D4,A2,1)>0,1,0)),0,1,1)

Vijaykumar Shetye,
India
 

Excel Facts

Difference between two dates
Secret function! Use =DATEDIF(A2,B2,"Y")&" years"&=DATEDIF(A2,B2,"YM")&" months"&=DATEDIF(A2,B2,"MD")&" days"
Re: June/July 2008 Challenge of the Month

Did not know about the posts and threads before creating this UDF so here is another variation.

I really like the simple solution though:
=LOOKUP(2^15,SEARCH(D$2:D$11,A2),E$2:E$11))
:)
Wow!

'---------------------------------------------------------------------------------------
' Module : UDF
' DateTime : 7/8/2008 14:02
' Author : Nenad Stojkovski
' Purpose : MRExcel Challange June 2008
'---------------------------------------------------------------------------------------
Option Explicit
'---------------------------------------------------------------------------------------
' Procedure : us of the UDF: =IDAssigned(A2)
' Purpose : Find the color in the text and assign the Name of the person from the table to the right
'---------------------------------------------------------------------------------------
'
Public Function IDAssigned(CellRef As Range)
Dim cCell As Range
Dim strTestVal As String
Dim Bullpen As String
Dim varFindRef As Variant
Dim wks As Worksheet
Dim rngLookupRange As Range
Dim SrchVals As Range
Set wks = ThisWorkbook.Worksheets("Sheet1")
'Dynamic Range for the Colors and Assigned map
Set SrchVals = _
wks.Range(Range("D2"), Range("D" & Rows.Count).End(xlUp))
'Check if the Phrases is blank
If Len(CellRef) = 0 Then
IDAssigned = "No Match"
Exit Function
End If
'Loop through colors values
For Each cCell In SrchVals.Cells
strTestVal = CStr(cCell.Value)
If Len(CellRef.Value) <> 0 Then
'List ref cell is not blank, so test the cell
varFindRef = InStr(1, CellRef, strTestVal)
If varFindRef > 0 Then
Bullpen = cCell.Offset(0, 1).Value
GoTo foundit
End If
End If
Next cCell
foundit:
If Bullpen = "" Then
IDAssigned = "No Match"
Else
IDAssigned = Bullpen
End If
End Function
 
Re: June/July 2008 Challenge of the Month

This is the best I could manage

=OFFSET(E1,MATCH(1,IF(SEARCH(D2:D4,A2,1)>0,1,0)),0,1,1)

Vijaykumar Shetye,
India

Hi Vijaykumar,

You can make the formula a little shorter (remove IF() argument) and add some $ so you can stretch it down:

=OFFSET($E$1,MATCH(1,SEARCH($D$2:$D$10,A2),-1),0)

Ctrl+Shift+Enter
 
Re: June/July 2008 Challenge of the Month

Well, nor nearly as slick as some of the ones above, but pretty expandable, gets the job done, and readable...I prefer UDFs because its easier to tell whats going on in the worksheet itself. You can fix the Redditch problem (or the ditchRed problem) by using some conditionals in the worksheet to see if the letter before or after the keyword in the phrase is a space.

The first function does the brunt of the work, but I also added a check for whitespace characters in the keywords (not just the phrases) that uses the second function posted below.

Code:
Function searchUsingKeywordTable(haystackRef As Range, needleTable As Range, Optional toggle As Integer = 1) As Variant
   
   'Like the Search worksheet function but allows searching from multiple keywords. Keywords can be more than one word apiece and contain any text.
   
   'haystackRef is a single cell reference with text to be searched. Ex "A1"
   'needleTable is a range, such as "A1:A10", that includes the keywords column. Do NOT include column headers or the Assigned to Coulmn.
   
   'When toggle is:
      '1: function returns the first keyword found in the searched text, or "#NA" if no keyword not found
      '2: function returns the position of the first letter of the first keyword found in the searched text, or "#NA" if no keyword found
      'Default value for toggle is 1
      
   searchUsingKeywordTable = CVErr(xlErrNum)
  
   Dim haystack As String
   haystack = haystackRef.Value
   
   'Although not an issue in this challenge, we dont want capitalization to throw off the search function, so lets make everything the same case
   haystack = UCase(haystack)
  
   'Now we loop through each keyword, using the Instr fxn to see of any of the keywords are in the haystack
   'Note the use of the cleanerText function. Although not needed for this challenge, this function makes it so that cells in the keyword
   ' column that are blank, or contain only spaces or even other non-space ascii whitespace or nonprinting characters, will not be searched for
   Dim cll As Object
   Dim cllValue As String
   For Each cll In needleTable
      cllValue = cll.Value
      If InStr(1, haystack, UCase(trim(cllValue))) And cleanerText(cllValue, True, True, True) <> "" Then
         If toggle = 1 Then
            searchUsingKeywordTable = cllValue
         Else
            searchUsingKeywordTable = InStr(1, haystack, UCase(cllValue))
         End If
         Exit For
      End If
   Next cll

End Function
Code:
Function cleanerText(text As String, Optional ConvertBreakingChars As Boolean = False, Optional RemoveNonPrintables As Boolean = False, Optional trimString As Boolean = False) As String
   
   'Replaces all nonbreaking whitespace characters with spaces
   'If ConvertBreakingChars is set to TRUE, also sets breaking whitespacecharacters to spaces (default is false)
   'If RemoveNonPrintables is set to TRUE, removes nonprinting characters (default is false)
   'If trimString is set to TRUE, trims spaces on both sides of string (default is false)
   
   'Add special characters to an array
   
   Dim Wspace() As String
   ReDim Wspace(1 To 6) As String
   
   Wspace(1) = Chr(9)
   Wspace(2) = Chr(0)
   Wspace(3) = Chr(1)
   Wspace(4) = Chr(2)
   Wspace(5) = Chr(3)
   Wspace(6) = Chr(160)
   
   If ConvertBreakingChars = True Then
      ReDim Preserve Wspace(1 To 8) As String
      Wspace(7) = Chr(10)
      Wspace(8) = Chr(13)
   End If
   
   'Loop through the array, replacing all wspace characters with spaces
   Dim i As Integer
   i = 1
   
   Do While i < (UBound(Wspace) + 1)
      Do While InStr(1, text, Wspace(i))
         text = Replace(text, Wspace(i), " ")
      Loop
      i = i + 1
   Loop
   
   If RemoveNonPrintables = True Then
      text = Application.WorksheetFunction.Clean(text)
   End If
   
   If trimString = True Then
      text = trim(text)
   End If
   
   cleanerText = text
   
End Function
 
Re: June/July 2008 Challenge of the Month

If I had realised earlier that the solution had to be 'posted' instead of emailing the workbook, I would have done this earlier.
I prefer the UDF solution that is likely to make sense to me in a few months time instead of a formula that is going to make my head ache.
My solution is:
Code:
Function ReverseLOOKUP(rngCell As Range, rngTable As Range, lngColumn As Long) As String
Application.Volatile
Dim rng As Range
If ((lngColumn > rngTable.Columns.Count) Or (lngColumn < 1)) Then
    ReverseLOOKUP = "#REF!"
Else
    For Each rng In rngTable.Columns(1).Cells
        If InStr(1, rngCell.Value, rng.Value) > 0 Then
            ReverseLOOKUP = Cells(rng.Row, rng.Column + lngColumn - 1)
            Exit For
        End If
    Next rng
End If
Set rng = Nothing
End Function
and then, for example, in Cell B2 the formula would be:
=reverselookup(A2,$D$2:$E$10,2)
 
Re: June/July 2008 Challenge of the Month

soodaarti21,

Suggest you post your answer to the board - not sure that anyone's going to navigate to an unknown sits & challenge instructions were to post to this thread.
 
Re: June/July 2008 Challenge of the Month

Dim i As Integer
Dim j As Integer
For i = 2 To 100
For j = 2 To 100
Cells(i, 8) = "=Search(D" & j & ", A" & i & ", 1)"
If Not IsError(Cells(i, 8)) Then
Cells(i, 9) = Cells(j, 4)
Cells(i, 2) = Cells(j, 5)
GoTo a
End If

Next

a: Next
Sheet1.Range("H:I").ClearContents
 
Re: June/July 2008 Challenge of the Month

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.

Rich (BB code):
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
 
Last edited:
Re: June/July 2008 Challenge of the Month

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)
 

Forum statistics

Threads
1,212,934
Messages
6,110,760
Members
448,295
Latest member
Uzair Tahir Khan

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