Select values next to matching cells - excel

I have a spreadsheet with two columns, key and name. Right now, the name gets repeated multiple times per value. I set up a formula to get unique values in name, but now I need to get a list of all the values of the cells that match that column.
So if I have the name 'Brian', and there are 4 of them with index values of 5, 6, 7, and 8, I need a formula to take/use the value of C1 to look at B:B and give me all values in A:A.
Is this possible?

In your google-sheets's D1 put this formula in and drag down.
=arrayformula(textjoin(" ", true, if(B:B=C1, A:A, "")))

CONCIF (UDF)
In Excel
=CONCIF($B$1:$B$20,$C1,$A$1:$A$20)
In VBA
Option Explicit
Function CONCIF(MatchRange As Range, ByVal MatchValue As Variant, _
ConcatRange As Range, _
Optional ByVal Delimiter As String = " ") As String
Dim vntM As Variant ' Match Array
Dim vntC As Variant ' Concat Array
Dim Nor As Long ' Number of Rows
Dim i As Long ' Row Counter
Dim strC As String ' Concat String
Dim strR As String ' Result String
' Check number of rows in MatchRange is less than or equal to number
' of rows in Concat Range.
If MatchRange.Rows.Count <= ConcatRange.Rows.Count Then
' Write number of rows in MatchRange to Number of Rows.
Nor = MatchRange.Rows.Count
Else
' Write number of rows in ConcatRange to Number of Rows.
Nor = ConcatRange.Rows.Count
End If
' Check if Number of Rows is equal to 1, which would mean there
' can only be one match.
If Nor = 1 Then
' Check if the value in 1-cell MatchRange is equal to MatchValue.
If MatchRange.Cells(1, 1) = MatchValue Then
' Write value of 1-cell ConcatRange, converted to string, to CONCIF.
CONCIF = CStr(ConcatRange.Cells(1, 1))
End If
Exit Function
End If
' Copy the range defined by 1st Nor number of cells in 1st column of
' MatchRange to 2D 1-based 1-column Match Array.
vntM = MatchRange.Cells(1, 1).Resize(Nor)
' Copy the range defined by 1st Nor number of cells in 1st column of
' ConcatRange to 2D 1-based 1-column Concat Array.
vntC = ConcatRange.Cells(1, 1).Resize(Nor)
' Loop through elements (rows) of Match/Concat Arrays.
For i = 1 To Nor
' Check if current value in MatchArray is equal to MatchValue.
If vntM(i, 1) = MatchValue Then
' Write current value in ConcatArray to Concat String.
strC = CStr(vntC(i, 1))
' Check if Concat String is NOT "".
If strC <> "" Then
' Check if Result String is NOT "".
If strR <> "" Then
' Concatenate current value of Result String, Delimiter
' and Concat String, to Result String.
strR = strR & Delimiter & strC
Else
' Write Concat String to Result String (only once).
strR = strC
End If
End If
End If
Next
' Write Result String to CONCIF.
CONCIF = strR
End Function

Related

Counting a specific number from a group of numbers separated by comma in a range of cells in excel

I have a special case where I need to count a specific number from a range of cells or a column, which will look like this
1 A
2 1,2,3
3 1,4,5
4 1,3,5,6
I need to count the "1" alone from this column A. Same way for every other numbers e.g., '2', '3' etc..
I have tried the following code, however it gives me the unique numbers count from a single cell
Public Function Count(r As Range) As Long
Dim c As Collection
Set c = New Collection
ary = Split(r.Text, ",")
On Error Resume Next
For Each a In ary
c.Add a, CStr(a)
If Err.Number = 0 Then
Count = Count + 1
Else
Err.Number = 0
End If
Next a
On Error GoTo 0
End Function`
How do I change this to a range as well as only specific to counting one number from that range?
You can do something like this:
Public Function CountNum(rng As Range, num) As Long
Dim rv As Long, c As Range, arr, a
num = CStr(num)
For Each c In rng.Cells
If Len(c.Value) > 0 Then
arr = Split(c.Value, ",")
For Each a In arr
If a = num Then rv = rv + 1
Next a
End If
Next c
CountNum = rv
End Function
To call (for example):
=countnum(A2:A4,1)
Count Delimited String Occurrences (UDF)
The Code
'***********************************************************************
' Title: Count Delimited String Occurrences
' Purpose: Counts the number of occurrences of a value in delimited parts
' of cells of a range containing not numeric values.
' Inputs:
' CountRange: Required. The range which cells to search.
' CountValue: Required. The value to search for. Variant.
' CountDelimiter: Optional. The delimiter by which each part of each
' cell will be checked against CountValue. Default is ",".
' CompareBinary0Text1: Optional. The method how the check will be
' performed. (Binary) - 0 i.e. AA <> Aa <> aa. Default.
' (Textual) - 1 i.e. AA = Aa = aa.
' All0OnlyOne1: Optional. Determines if all (0 - Default) or only
' the first (1) occurrence in each cell has to be found.
'*************************************************************************
Function CDSO(CountRange As Range, CountValue As Variant, _
Optional CountDelimiter As String = ",", _
Optional CompareBinary0Text1 As Long = 0, _
Optional All0OnlyOne1 As Long) As Long
Dim rng As Range ' Current Range (of Areas Collection)
Dim vntR As Variant ' Range Array (2D 1-based)
Dim vntC As Variant ' Cell Array (1D 0-based)
Dim vntCell As Variant ' Cell Variant
Dim i As Long ' Current Cell Row Counter
Dim j As Long ' Current Cell Column Counter
Dim k As Long ' CountRange Areas Counter
Dim m As Long ' Cell Array Element Counter
Dim ValCount As Long ' Value Counter
Dim strVal As String ' Value String
Dim strCell As String ' Cell String
' Convert CountValue to string (CStr), because arrays created
' using Split do only contain strings.
' Write CountValue to Value String.
strVal = CStr(CountValue)
' Loop through Areas Collection (ranges) of CountRange.
For k = 1 To CountRange.Areas.Count
' Check if Current Range contains one cell only.
If CountRange.Areas(k).Cells.Count = 1 Then
' Write value of Current Range (one cell only) to Cell Variant.
vntCell = CountRange.Areas(k)
' Go to Occurrences Counter Subroutine.
GoSub OccurrencesCounter
Else
' Copy Current Range to Range Array.
vntR = CountRange.Areas(k)
' Loop through rows of Range Array.
For i = 1 To UBound(vntR)
' Loop through columns of Range Array.
For j = 1 To UBound(vntR, 2)
' Write value of current element of Range Array to Cell
' Variant.
vntCell = vntR(i, j)
' Go to Occurrences Counter Subroutine.
GoSub OccurrencesCounter
Next
Next
End If
Next
' Write value of Value Counter to Count String Occurrences (CDSO).
CDSO = ValCount
Exit Function
' Occurrences Counter
' Purpose: Count the number of occurrences of CountValue in Cell String.
OccurrencesCounter:
' Check if Cell Variant is a number.
If IsNumeric(vntCell) Then Return
' Write value of Cell Variant converted to string to Cell String.
strCell = CStr(vntCell)
' Check if Cell String is not empty ("").
If strCell = "" Then Return
' Split Cell String by CountDelimiter into Cell Array.
vntC = Split(strCell, CountDelimiter)
' Loop through elements of Cell Array.
For m = 0 To UBound(vntC)
' Sometimes the values contain deliberate or accidental
' spaces, so Trim is used to remove them.
' If you want to use the vbTextCompare i.e. AA = Aa, AA = aa,
' in the formula set CompareBinary0Text1 to 1.
' Check if value of current element in Cell Array
' is equal to CountValue.
If StrComp(Trim(vntC(m)), strVal, CompareBinary0Text1) = 0 Then
' Count the occurrence i.e. increase Value Counter.
ValCount = ValCount + 1
' Note: If only the first occurrence in each cell is needed,
' increase efficiency with Exit For i.e. in the formula
' set All0OnlyOne1 to 1.
' Check if All0OnlyOne1 is equal to 1.
If All0OnlyOne1 = 1 Then
' Stop looping, occurrence found.
Exit For
End If
End If
Next
Return
End Function
'******************************************************************************

Conditional Concatenation in Excel

As you can see in the image, there are some 1 and 0s rearranged in 3 rows and one English Alphabet for each column. What I need to do is concatenate the English Alphabets for each row when the respective column value is 0. How can I do it?
Here is a VBA solution that can handle any number of columns (assuming that the letter associated with each column is the standard column label):
Function ZeroColumns(R As Range) As String
Dim n As Long
Dim count As Long
Dim cols As Variant
Dim cell As Range
n = R.Cells.count
ReDim cols(1 To n)
For Each cell In R.Cells
If cell.Value = 0 Then
count = count + 1
cols(count) = Split(cell.Address, "$")(1)
End If
Next cell
ReDim Preserve cols(1 To count)
ZeroColumns = Join(cols, "")
End Function
The code shouldn't be too hard to tweak if the stated assumption doesn't hold.
Conditionally Concatenate Row (UDF)
Arguments
SourceRowRange: The range containing the values that will be
written toCCROW e.g. A, B, C ... Required.
CriteriaRowRange: The range that will be checked for
CriteriaValue. Required.
CriteriaValue: The value that the cells in CriteriaRowRange will
be checked against. Default is 0. Optional.
JoinString: The value that will be put between the values that will
be written to CCROW. Default is "". Optional.
' Copy the following code to a standard module i.e. in VBE go to Insert>Module.
The Code
Function CCROW(ByVal SourceRowRange As Range, ByVal CriteriaRowRange As Range, _
Optional ByVal CriteriaValue As Variant = 0, _
Optional ByVal JoinString As String) As String
Dim vntS As Variant ' Source Array
Dim vntC As Variant ' Criteria Array
Dim NoC As Long ' Number of Columns
Dim j As Long ' Arrays Column Counter
Dim strB As String ' String Builder
Dim strC As String ' Criteria String
' Calculate number of columns of the narrower Range.
NoC = WorksheetFunction.Min(SourceRowRange.Columns.count, _
CriteriaRowRange.Columns.count)
' Copy resized (adjust them to same size) Ranges to Arrays.
vntS = SourceRowRange.Resize(1, NoC)
vntC = CriteriaRowRange.Resize(1, NoC)
' Loop through columns of either Array.
For j = 1 To NoC
' Write current value of Criteria Array to Criteria String.
strC = vntC(1, j)
' Check if Criteria String is NOT empty.
If strC <> "" Then
' Check if Criteria String is equal to Criteria Value.
If strC = CriteriaValue Then
' Check if String Builder is NOT empty.
If strB <> "" Then ' NOT empty.
strB = strB & JoinString & vntS(1, j)
Else ' IS empty (only once).
strB = vntS(1, j)
End If
End If
End If
Next
' Write String Builder to Conditionally Concatenate Row.
CCROW = strB
End Function
Usage in Excel
=CCROW(A$1:I$1,A3:I3) ' Result: ADG
=CCROW(A$1:I$1,A4:I4) ' Result: CFI
=CCROW(A$1:I$1,A5:I5) ' Result: DG
If you add JoinString:
=CCROW(A$1:I$1,A3:I3,,",") ' Result: A,D,G
=CCROW(A$1:I$1,A3:I3,0,",") ' Result: A,D,G
=CCROW(A$1:I$1,A3:I3,0,", ") ' Result: A, D, G
IF you change CriteriaValue:
=CCROW(A$1:I$1,A3:I3,1) ' Result: BCEFHI
=CCROW(A$1:I$1,A4:I4,1) ' Result: ABDEGH
=CCROW(A$1:I$1,A5:I5,1) ' Result: ABCEFHI
Remarks
Lock ($) the row of SourceRowRange to keep it the same when the formula is copied down.
You can do it all in one formula if you like:
=CONCATENATE(IF($A1=0,'A',''),IF($B1=0,'B',''), ...)
Or put the intermediate strings in a separate row and then concatenate them (to save wear and tear on your fingers).
Are you going to this to many more columns, or just the ones you've mentioned? As long as the number of columns is relatively small, as in your picture, you can concatenate IF functions to achieve your result.
Here's what I did:
Using that formula will get you a result like the one you have:
Assuming also that you have the values in a worksheet like mine, just paste the formula =IF(B3=1,"",B$1)&IF(C3=1,"",C$1)&IF(D3=1,"",D$1)&IF(E3=1,"",E$1)&IF(F3=1,"",F$1)&IF(G3=1,"",G$1)&IF(H3=1,"",H$1)&IF(I3=1,"",I$1)&IF(J3=1,"",J$1)
in B7 and then drag to B8 and B9 to get the rest of the results.
Of course, if you are going to do this for many more columns, it's maybe best to use VBA.
Here, add this function to a module.
You can then call it directly via excel. Nice one.
Function conc(ref As Range, Optional Separator As String) As String
Dim Cell As Range
Dim Result As String
For Each Cell In ref
If Cell.Value = 0 Then
Result = Result & chr(64 + Cell.Column) & Separator
End If
Next Cell
If Separator <> "" Then conc = Left(Result, Len(Result) - 1) Else: conc = Result
End Function
The following array formula will do the job (enter it with Ctrl+Shift+Enter):
=CONCAT(IF($A1:$I1=0,UNICHAR(64+COLUMN($A1:$I1)),""))
For older Excel versions, use the legacy functions CONCATENATE() and CHAR() in place of these functions.

How do I split a range of values with commas and "and" before the last value?

I'm trying to make a code that allows the user to enter a list of items from A1 downwards, and display them all as a list in a sentence with correct commas and 'and' placement.
E.g for the below,
A1. Shoe
A2. Tree
A3. Box
A4. Toy
I want a message box to display "You have entered Shoe, Tree, Box and Toy".
I'm completely lost with how to get it to recognise where to put the 'and'.
Any help is appreciated.
I've tried to complete this with some For statements, but I get stuck when identifying where or how to put the 'and' in the list, considering there could be a different number of items in the list.
Thanks
You can try this code:
Sub Sample()
' Define object variables
Dim listRange As Range
Dim cellValue As Range
' Define other variables
Dim itemsQuantity As Integer
Dim stringResult As String
Dim separator As String
Dim counter As Integer
' Define the range where the options are located
Set listRange = Range("A1:A4")
itemsQuantity = listRange.Cells.Count
counter = 1
For Each cellValue In listRange
' Select the case for inner items, penultimate and last item
Select Case counter
Case Is < itemsQuantity
separator = ", "
Case Is = itemsQuantity - 1
separator = " And "
Case Else
separator = vbNullString
End Select
stringResult = stringResult & cellValue.Value & separator
counter = counter + 1
Next cellValue
' Assamble the last sentence
stringResult = "You have entered " & stringResult & "."
MsgBox stringResult
End Sub
Customize the:
' Define the range where the options are located portion
Cheers!
Column to Sentence
Features
At least two cells of data in Range, or else "" is returned.
Only first column of Range is processed (Resize).
Usage in Excel
The Code
Function CCE(Range As Range) As String
Application.Volatile
Const strFirst = "You have entered " ' First String
Const strDEL = ", " ' Delimiter
Const strDELLast = " and " ' Last Delimiter
Const strLast = "." ' Last String
Dim vnt1 As Variant ' Source Array
Dim vnt0 As Variant ' Zero Array
Dim i As Long ' Arrays Row Counter
' Copy Source Range's first column to 2D 1-based 1-column Source Array.
vnt1 = Range.Resize(, 1)
' Note: Join can be used only on a 0-based 1D array.
' Resize Zero Array to hold all data from Source Array.
ReDim vnt0(UBound(vnt1) - 1)
' Copy data from Source Array to Zero Array.
For i = 1 To UBound(vnt1)
If vnt1(i, 1) = "" Then Exit For
vnt0(i - 1) = vnt1(i, 1)
Next
' If no "" was found, "i" has to be greater than 3 ensuring that
' Source Range contains at least 2 cells.
If i < 3 Then Exit Function
ReDim Preserve vnt0(i - 2)
' Join data from Zero Array to CCE.
CCE = Join(vnt0, strDEL)
' Replace last occurence of strDEL with strDELLast.
CCE = WorksheetFunction.Replace( _
CCE, InStrRev(CCE, strDEL), Len(strDEL), strDELLast)
' Add First and Last Strings.
CCE = strFirst & CCE & strLast
End Function
Array solution via Join with simple transposition
Your post assumes a flexible range in column A:A, so the first step [1] gets the last row number and defines the data range.
In step [2] you assign the found data range to an array which has to be variant. The Application.Transpose function changes the original column data to a "flat" array in only one code line and reduces its 2-dim default dimension to a simple 1-dim array. Furthermore the last element is simply enriched by insertion of " and ". This allows you to avoid a complicated split & find action.
Step [3] allows to concatenate any 1-dim array via the Join function and insert any user defined delimiter (e.g. a colon ","). Finally the leading colon before " and" gets deleted by replacing ", and " with " and" only.
Step [4] displays the resulting message box.
Example code
Option Explicit ' declaration head of your code module
Sub displayMsg()
' [0] declare constants and variables
Const LNK$ = " and ", COLON$ = "," ' define linking constants "and" plus COLON
Dim v As Variant, msg$, lastRow& ' provide for variant datafield array and message string
Dim ws As Worksheet, rng As Range ' declare worksheet object *)
Set ws = ThisWorkbook.Worksheets("MySheetName") ' << change to your sheet name *)
' [1] define flexible range object in column A:A via last row number
lastRow = ws.Range("A" & ws.Rows.count).End(xlUp).Row
Set rng = ws.Range("A1:A" & lastRow) ' e.g. A1:A4, if n = 4
' [2] get 2-dim column data to "flat" 1-dim array
v = Application.Transpose(rng) ' read into array and make it "flat"
v(UBound(v)) = LNK & v(UBound(v)) ' insert " and " into last array element
' [3] concatenate elements and delete superfluous last colon
msg = Replace(Join(v, COLON), COLON & LNK, LNK) ' get wanted message string
' [4] display message
MsgBox "You have entered " & msg & ".", vbInformation, UBound(v) & " elements"
End Sub
Alternative referencing
*) Instead of referencing a work sheet ws by e.g. ThisWorkBook.Worksheets("MySheetName"), you can simply use the worksheet's CodeName instead as listed in the VB Editor (without declaring ws as well as setting it into the memory) just coding as follows:
' [1] define flexible range object in column A:A via last row number
lastRow = Sheet1.Range("A" & Sheet1.Rows.count).End(xlUp).Row
Set rng = Sheet1.Range("A1:A" & lastRow)
Enjoy it :-)

Cell character counting formula?

I need a formula that counts the total number of characters in a cell but also will count how many times that number of characters occurs.
For example in column A:
A range of 10 cells with 201, 202, 203, 204, 205, 1001, 1002, 1003, 1004, 1005.
There are 5 cells with 3 characters and 5 cells with 4 characters.
What would the formula be for this? Not sure how high I would need to go in terms of how many characters in each cell to count but I'm hoping that's an easy edit in the formula later on.
With data in column A, in B1 enter:
=SUMPRODUCT(--(LEN(A:A)=ROW()))
and copy downwards:
Add a helper column with the formula =len(A1) and copy that for column A.
Then you can have a list of the different values 3,4,5... and countif(B:B,C1) and that will give you the count of values with length 3.
For the number of chars, use another column with =len(cell).
Then make a dynamic table where you put the len column at the left side of the table and the len column again at the middle. Make sure the table is saying "count of len" or something very similar to this.
Cell Characters Count Array Version
Option Explicit
Sub CellCharactersCount()
Const cVntWsName As Variant = "Sheet1" ' Worksheet Name or Index
Const cStrFirstSource As String = "A1" ' First Cell of Source Column
Const cStrFirstTarget As String = "B1" ' First Cell of Target Column
Dim vntSource As Variant ' Source Array
Dim vntLngTarget As Variant ' Target Array (As Long)
Dim lng1 As Long, lng2 As Long ' Array Row Counters
Dim lngMax As Long ' Maximum Characters
' Paste range into Source Array
With ThisWorkbook.Worksheets(cVntWsName)
vntSource = .Range(.Range(cStrFirstSource), .Cells(Rows.Count, _
.Range(cStrFirstSource).Column).End(xlUp))
End With
' Count the maximum number of chars.
For lng1 = 1 To UBound(vntSource)
If Len(vntSource(lng1, 1)) > lngMax Then
lngMax = Len(vntSource(lng1, 1))
End If
Next
' Copy Len Data to Target Array.
ReDim vntLngTarget(1 To lngMax, 1 To 1) As Long
For lng1 = 1 To UBound(vntSource)
If Len(vntSource(lng1, 1)) <> 0 Then
For lng2 = 1 To lngMax
If Len(vntSource(lng1, 1)) = lng2 Then
vntLngTarget(lng2, 1) = vntLngTarget(lng2, 1) + 1
End If
Next
End If
Next
With ThisWorkbook.Worksheets(cVntWsName)
' Clear contents of Target Column Range.
.Range(cStrFirstTarget) _
.Resize(Rows.Count - .Range(cStrFirstTarget).Row + 1).ClearContents
' Paste Target Array into Target Range.
.Range(cStrFirstTarget).Resize(lngMax) = vntLngTarget
End With
End Sub

Find keyword and scrape text from same field to convert to date

I am trying to work out how to create an Excel function that will find a keyword in any row within a defined column, and then will scrape text in the same field (in dd/mm/yy format), converting it to date in a new column.
Example of field data ['Keyword' , 13/10/17]
Is this possible in Excel? would VBA be needed?
Thanks
Example using a datafield array:
Always declare your variables using the Option Explicit expression in the declaration head of your code module. The procedure code shows you a fast method using a data field array instead of looping through a range. You can easily set range values to a variant array by this example code:
Dim a ' variant
a = ThisWorkbook.Range("A2:A4711").value
By that way you can speed up your search. Keep in mind that VBA then creates automatically a one based array with Dimension 2.
What does the below procedure?
searches for "Keyword" in col A,
gets string ("13/10/17") of col B, convert to date and
writes date to col C in sheet Test
Test Call
Option Explicit
' Note: write Option Explicit into your code module's declaration head
Sub TestCall()
' Example
writeKeyDate "Keyword", "A", "B", "C", "Test"
End Sub
Procedure code
Sub writeKeyDate(ByVal sKey As String, _
ByVal sCol As String, ByVal sCol2 As String, ByVal sCol3 As String, _
Optional ByVal wsName As String = "Test")
' sKey .... search string
' sCol .... character of column where to search
' sCol2 ... character of column with datestring
' sCol3 ... character of target column
' wsName .. worksheet name as string, e.g. "MySheet", or "Test"
' (if not set, then automatically "Test")
' declare vars
Dim oSht As Worksheet ' work sheet
Dim a As Variant ' one based 2-dim data field array
Dim i As Long ' rows
Dim n As Long ' last row
Dim sDate As String ' date string in sCol2
' set sheet
Set oSht = ThisWorkbook.Worksheets(wsName) ' fully qualified reference to worksheet
' get last row number of search column
n = oSht.Range(sCol & oSht.Rows.Count).End(xlUp).Row
If n < 2 Then Exit Sub ' only if data avaible (row 1 assumed as head line)
' get range values to one based 2dim data field array
a = oSht.Range(sCol & "2:" & sCol & n).Value ' array gets data from e.g. "A2:A100"
' loop through column sCol to find keyword sKey
For i = LBound(a) To UBound(a) ' array boundaries counting from 1 to n -1 (one off for title line)
' searchstring found
If LCase(a(i, 1)) = LCase(sKey) Then ' case insensitive
sDate = oSht.Range(sCol2 & i + 1).Value2
On Error Resume Next
If Len(Trim(sDate)) > 0 Then
oSht.Range(sCol3 & i + 1).Value = CDate(sDate)
End If
End If
Next
End Sub
Note
a) I assume you have a title line in row 1.
b) The procedure writes back any code finding (case insensitive); if you have unique keys only you could include a Exit Forin the last Ifcondition:
If Len(Trim(sDate)) > 0 Then
oSht.Range(sCol3 & i + 1).Value = CDate(sDate)
' >>>> possible insert, if unique keys only >>>>
Exit For
End If
c) If you want the search case sensitive you have to change code as follows:
If a(i, 1) = sKey instead of If LCase(a(i, 1)) = LCase(sKey)
Good luck.
============================================
EDIT example for search and data within cell in same column (colon separated)
Sub TestCall1()
' Example
writeKeyDate1 "Keyword", "A", "B", "Test"
End Sub
Edited procedure for search in ONE column
Sub writeKeyDate1(ByVal skey As String, _
ByVal sCol As String, ByVal sCol2 As String, _
Optional ByVal wsName As String = "Test")
' sKey .... search string
' sCol .... character of column where to search (includes key, date string)
' sCol2 ... character of target column
' wsName .. worksheet name as string, e.g. "MySheet", or "Test"
' (if not set, then automatically "Test")
' declare vars
Dim oSht As Worksheet ' work sheet
Dim a As Variant ' one based 2-dim data field array
Dim i As Long ' rows
Dim n As Long ' last row
Dim s As String
Dim sDate As String ' date string in sCol2
' set sheet
Set oSht = ThisWorkbook.Worksheets(wsName) ' fully qualified reference to worksheet
' get last row number of search column
n = oSht.Range(sCol & oSht.Rows.Count).End(xlUp).Row
If n < 2 Then Exit Sub ' only if data avaible (row 1 assumed as head line)
' get range values to one based 2dim data field array
a = oSht.Range(sCol & "2:" & sCol & n).Value ' array gets data from e.g. "A2:A100"
' loop through column sCol to find keyword sKey
For i = LBound(a) To UBound(a) ' array boundaries counting from 1 to n -1 (one off for title line)
s = Split(LCase(a(i, 1)) & "", ",")(0)
' searchstring found
If InStr(LCase(s), LCase(skey)) > 0 Then
sDate = Trim(Split(LCase(a(i, 1)) & ",", ",")(1))
On Error Resume Next
If Len(sDate) > 0 Then
oSht.Range(sCol2 & i + 1).Value = CDate(sDate)
End If
End If
Next
End Sub

Resources