I'm trying to write a VBA code that will take values from a selection and concatenate the cell values with a line seperator. I also wish to not include and duplicates.
Ex. as follows:
Say I have a data set like the below. I would like to type =ConcatenateUnique(A1:B2,",") and have it return One,Two,Three
Column A
Column B
One
Two
Three
One
I tried the below, although I'm aware if it did work it would only return Two,Three
Function CONCATENATEUNIQUE(Ref As Range, Separator As String) As String
Dim Cell As Range
Dim Result As String
For Each Cell In Ref
If WorksheetFunction.CountIf(Ref, Cell.Value) <= 1 Then
Result = Result & Cell.Value & Separator
End If
Next Cell
CONCATENATEMULTIPLE = Left(Result, Len(Result) - 1)
End Function
For this type of task a Scripting Dictionary is useful (but note this won't work on a Mac):
Function UniqueList(rng As Range, Optional sep As String = ",")
Dim arr, r As Long, c As Long, v, dict As Object
If rng.Count = 1 Then 'handle single-cell case
UniqueList = rng.Value
Exit Function
End If
arr = rng.Value 'get values into an array
Set dict = CreateObject("Scripting.Dictionary")
For r = 1 To UBound(arr, 1)
For c = 1 To UBound(arr, 2)
v = arr(r, c)
If Not IsError(v) Then
If Len(v) > 0 Then dict(v) = True
End If
Next c
Next r
UniqueList = Join(Application.Transpose( _
Application.Transpose(dict.Keys)), sep)
End Function
Related
Hello smart human beings out there
I have this setup in my Excel
Basically, what I'm trying to achieve here is automatically grab every single string from column A (and paste to column H) and return the frequency in column I. The script is below
Sub WordCountTester()
Dim d As Object, k, i As Long, ws As Worksheet
Set ws = ActiveSheet
With ws.ListObjects("Table3")
If Not .DataBodyRange Is Nothing Then
.DataBodyRange.Delete
End If
End With
Set d = WordCounts(ws.Range("A2:A" & ws.Cells(Rows.Count, "A").End(xlUp).Row), _
ws.Range("F2:F" & ws.Cells(Rows.Count, "F").End(xlUp).Row))
'list words and frequencies
For Each k In d.keys
ws.Range("H2").Resize(1, 2).Offset(i, 0).Value = Array(k, d(k))
i = i + 1
Next k
End Sub
'rngTexts = range with text to be word-counted, defined in set d= above
'rngExclude = 'range with words to exclude from count, defined in set d= above
Public Function WordCounts(rngTexts As Range, rngExclude As Range) As Object 'dictionary
Dim words, c As Range, dict As Object, regexp As Object, w, wd As String, m
Set dict = CreateObject("scripting.dictionary")
Set regexp = CreateObject("VBScript.RegExp") 'see link below for reference
With regexp
.Global = True
.MultiLine = True
.ignorecase = True
.Pattern = "[\dA-Z-]{3,}" 'at least 3 characters
End With
'loop over input range
For Each c In rngTexts.Cells
If Len(c.Value) > 0 Then
Set words = regexp.Execute(LCase(c.Value))
'loop over matches
For Each w In words
wd = w.Value 'the text of the match
If Len(wd) > 1 Then 'EDIT: ignore single characters
'increment count if the word is not found in the "excluded" range
If IsError(Application.Match(wd, rngExclude, 0)) Then
dict(wd) = dict(wd) + 1
End If
End If '>1 char
Next w
End If
Next c
Set WordCounts = dict
End Function
However, it currently count the string with 1 word only. I want to count strings with 2 and 3 words (and I will consider drive-by as 2 words). Can someone please tell me where in this code I have to fix to achieve that? I still want to keep column F there because there can be 2- or 3- word strings that I want to exclude. Thanks!
If you changed your mind and consider that also two words pairs 2-3, 4-5, 6-7 and so on are necessary, please test the next solution:
Private Sub WordPairsCountTester()
Dim d As Object, k, i As Long, ws As Worksheet, arrFin
Set ws = ActiveSheet
'Attention, please! The last parameter of the called function means How Many Consecutive Words to be counted
Set d = WordPairCountsSp(ws.Range("A2:A" & ws.cells(rows.count, "A").End(xlUp).row), _
ws.Range("F2:F" & ws.cells(rows.count, "F").End(xlUp).row), 3)
arrFin = Application.Transpose(Array(d.Keys, d.items)) 'place the dictionary in an array
'clear contents of the columns where a previous result was returned, if any...:
ws.Range("H2:I" & ws.Range("H" & ws.rows.count).End(xlUp).row).ClearContents
ws.Range("H2").Resize(UBound(arrFin), 2).Value = arrFin 'drop the array content at once
End Sub
Private Function WordPairCountsSp(rngTexts As Range, rngExclude As Range, nrNeigh As Long) As Object
Dim dict As Object, arr, arrCell, i As Long, pairWd As String, j As Long, k As Long
arr = rngTexts.Value 'place the range in an array for faster iteration
Set dict = CreateObject("scripting.dictionary")
For i = 1 To UBound(arr) 'iterate between the array elements
arrCell = Split(Replace(Replace(Replace(Replace(arr(i, 1), ",", ""), ".", ""), "?", ""), "!", "")) 'split the string by default delimiter (space)
If UBound(arrCell) + 1 >= nrNeigh Then
For j = 0 To UBound(arrCell) - nrNeigh + 1 'iterate between the array elements
pairWd = arrCell(j)
For k = 1 To nrNeigh - 1
pairWd = pairWd & " " & arrCell(j + k) 'create a string from nrNeigh neighbour words
Next k
If IsError(Application.match(pairWd, rngExclude, 0)) Then
dict(pairWd) = dict(pairWd) + 1 'place the unique pairs as keys and add occurrences as items
End If
Next j
End If
Next i
Set WordPairCountsSp = dict 'return the above created dictionary
End Function
Using a Macro or Formula, is there a way to achieve the result of the following formula of Office 365?
=FILTER(B:B,A:A = "x")
What it does is get all the values from Column B if Column A on the same row has a value of x.
My PC has office 365 but the one I'm working with only has Office Pro Plus 2019. I had to use my pc when I needed the function and I'm getting tired of it, maybe it can be done on Office Pro Plus 2019 too using a formula or a macro?
Use:
=IFERROR(INDEX($B$1:$B$100,AGGREGATE(15,7,ROW($A$1:$A$100)/($A$1:$A$100="x"),ROW($ZZ1))),"")
Note the use of a set range and not full columns. That is done on purpose, This being an array formula it will do a lot of calculations each cell it is placed. Limiting the range to the data set will speed it up.
Put this in the first cell of the output and copy down till blanks are returned.
I had some spare time and I am recently interested in User defined functions so I decided to make my own version of what I imagine this would be. I'm prefacing this by saying its not good and is excessively long but it works!
Function JOINIF(ByRef IfRange As Range, ByVal Criteria As String, Optional JoinRange As Range, Optional Delimeter As String = ",") As String
'IfRange is the range that will be evaluated by the Criteria
'Criteria is a logical test that can be applied to a cell value.
'Examples of Criteria: "=Steve", ">100", "<>Toronto", "<=-1"
'JoinRange is the range of values that will be concatenated if the corresponding -
'IfRange cell meets the criteria. JoinRange can be left blank if the values to be -
'concatenated are the IfRange values.
'Delimeter is the string that will seperate the concatenated values.
'Default delimeter is a comma.
Dim IfArr() As Variant, JoinArr() As Variant, OutputArr() As String
Dim IfArrDim As Integer, JoinArrDim As Integer
Dim JCount As Long, LoopEnd(1 To 2) As Long
Dim MeetsCriteria As Boolean, Expression As String
Dim i As Long, j As Long
'PARSING THE CRITERIA
Dim Regex As Object
Set Regex = CreateObject("VBScript.RegExp")
Regex.Pattern = "[=<>]+"
'Looking for comparison operators
Dim Matches As Object
Set Matches = Regex.Execute(Criteria)
If Matches.Count = 0 Then
'If no operators found, assume default "Equal to"
If Not IsNumeric(Criteria) Then
'Add quotation marks to allow string comparisons
Criteria = "=""" & Criteria & """"
End If
Else
If Not IsNumeric(Replace(Criteria, Matches(0), "")) Then
Criteria = Matches(0) & """" & Replace(Criteria, Matches(0), "") & """"
End If
'Add quotation marks to allow string comparisons
End If
'Trim IfRange to UsedRange
Set IfRange = Intersect(IfRange, IfRange.Parent.UsedRange)
'Default option for optional JoinRange input
If JoinRange Is Nothing Then
Set JoinRange = IfRange
Else
Set JoinRange = Intersect(JoinRange, JoinRange.Parent.UsedRange)
End If
'DIMENSIONS
'Filling the arrays
If IfRange.Cells.Count > 1 Then
IfArr = IfRange.Value
IfArrDim = Dimensions(IfArr)
Else
ReDim IfArr(1 To 1)
IfArr(1) = IfRange.Value
IfArrDim = 1
End If
If JoinRange.Cells.Count > 1 Then
JoinArr = JoinRange.Value
JoinArrDim = Dimensions(JoinArr)
Else
ReDim JoinArr(1 To 1)
JoinArr(1) = JoinRange.Value
JoinArrDim = 1
End If
'Initialize the Output array to the smaller of the two input arrays.
ReDim OutputArr(IIf(IfRange.Cells.Count < JoinRange.Cells.Count, IfRange.Cells.Count - 1, JoinRange.Cells.Count - 1))
'DEFINING THE LOOP PARAMETERS
'Loop ends on the smaller of the two arrays
If UBound(IfArr) > UBound(JoinArr) Then
LoopEnd(1) = UBound(JoinArr)
Else
LoopEnd(1) = UBound(IfArr)
End If
If IfArrDim = 2 Or JoinArrDim = 2 Then
If Not (IfArrDim = 2 And JoinArrDim = 2) Then
'mismatched dimensions
LoopEnd(2) = 1
ElseIf UBound(IfArr, 2) > UBound(JoinArr, 2) Then
LoopEnd(2) = UBound(JoinArr, 2)
Else
LoopEnd(2) = UBound(IfArr, 2)
End If
End If
'START LOOP
If IfArrDim = 1 Then
For i = 1 To LoopEnd(1)
If IsNumeric(IfArr(i)) And IfArr(i) <> "" Then
Expression = IfArr(i) & Criteria
Else
'Add quotation marks to allow string comparisons
Expression = """" & IfArr(i) & """" & Criteria
End If
MeetsCriteria = Application.Evaluate(Expression)
If MeetsCriteria Then
If JoinArrDim = 1 Then
OutputArr(JCount) = CStr(JoinArr(i))
Else
OutputArr(JCount) = CStr(JoinArr(i, 1))
End If
JCount = JCount + 1
End If
Next i
Else
For i = 1 To LoopEnd(1)
For j = 1 To LoopEnd(2)
If IsNumeric(IfArr(i, j)) And IfArr(i, j) <> "" Then
Expression = IfArr(i, j) & Criteria
Else
'Add quotation marks to allow string comparisons
Expression = """" & IfArr(i, j) & """" & Criteria
End If
MeetsCriteria = Application.Evaluate(Expression)
If MeetsCriteria Then
If JoinArrDim = 1 Then
OutputArr(JCount) = CStr(JoinArr(i))
Else
OutputArr(JCount) = CStr(JoinArr(i, j))
End If
JCount = JCount + 1
End If
Next j
Next i
End If
'END LOOP
ReDim Preserve OutputArr(JCount + 1 * (JCount > 0))
JOINIF = Join(OutputArr, Delimeter)
End Function
Private Function Dimensions(var As Variant) As Long
'Credit goes to the great Chip Pearson, chip#cpearson.com, www.cpearson.com
On Error GoTo Err
Dim i As Long, tmp As Long
While True
i = i + 1
tmp = UBound(var, i)
Wend
Err:
Dimensions = i - 1
End Function
Examples of it in use:
Seperate IfRange and JoinRange
IfRange as the JoinRange
You might try the following udf (example call: FILTER2(A1:A100,B1:B100)) consisting of the following tricky steps:
a) Evaluate the general condition (=If(A1:A100="x",Row(A1:A100),"?") as tabular Excel formula and assign all valid row numbers to array x (marking the rest by "?" strings),
b) Filter out all "?" elements
c) Apply x upon the data column benefitting from the advanced restructuring features of Application.Index()
Public Function Filter2(rng1 As Range, rng2 As Variant, Optional ByVal FilterID As String = "x")
Dim a As String: a = rng1.Address(False, False, External:=True)
'a) get all valid row numbers (rng1)
Dim myformula As String: myformula = "if(" & a & "=""" & FilterID & """,row(" & a & "),""?"")"
Dim x: x = Application.Transpose(Evaluate(myformula))
'b) filter out invalid "?" elements
x = VBA.Filter(x, "?", False)
'c) apply x upon data column (rng2)
If UBound(x) > -1 Then Filter2 = Application.Index(rng2, Application.Transpose(x), 1)
End Function
Note that function calls before versions 2019/MS 365 need to be entered as array formula (Ctrl+Shift+Enter).
The function assumes one-column (range) arguments.
Edit due to comment as of 2022-06-08
The whole example is based on the actual row numbers starting in the first row (OP ranges refer to A:A,B:B. If you want to allow ranges to start at any row, you'd need to change the myFormula definition in section a) by correcting the row indices by subtracting possible offsets (row number + 1 - first row):
Dim myFormula As String
myFormula = "if(" & a & "=""" & FilterID & """,row(" & a & ")+1 -" & rng1.Row & ",""?"")"
Try this UDF for the Filter Function:
Function FILTER_HA(Where, Criteria, Optional If_Empty) As Variant
Dim Data, Result
Dim i As Long, j As Long, k As Long
'Create space for the output (same size as input cells)
With Application.Caller
i = .Rows.Count
j = .Columns.Count
End With
'Clear
ReDim Result(1 To i, 1 To j)
For i = 1 To UBound(Result)
For j = 1 To UBound(Result, 2)
Result(i, j) = ""
Next
Next
'Count the rows to show
For i = 1 To UBound(Criteria)
If Criteria(i, 1) Then j = j + 1
Next
'Empty?
If j < 1 Then
If IsMissing(If_Empty) Then
Result(1, 1) = CVErr(xlErrNull)
Else
Result(1, 1) = If_Empty
End If
GoTo ExitPoint
End If
'Get all data
Data = Where.Value
'Copy the rows to show
For i = 1 To UBound(Data)
If Criteria(i, 1) Then
k = k + 1
For j = 1 To UBound(Data, 2)
Result(k, j) = Data(i, j)
Next
End If
Next
'Return the result
ExitPoint:
FILTER_HA = Result
End Function
How do I count the total number of "alt" and "first" that appeared in a cell and do the same for other cells as well while ignoring empty cells in the process? For instance, if a cell has first, first, alt, first, first, first, it should give me firstcounter = 5 (where firstcounter is the total count for first) and altcounter= 1(altcounter is the total count for alt). After that I can use the value of firstcounter and altcounter found to concatenate them into a string as shown in column B in the form of "first-" & firstcounter, "alt-"& altcounter.
Dim ia As Long
Dim lastrow2 As Long
Dim ws1 As Worksheet
Set ws1 = ThisWorkbook.Sheets(1)
lastrow2 = ws1.Range("A" & ws1.Rows.count).End(xlUp).Row
For ia = 2 To lastrow2
Dim arr() As Variant
' Split the string to an array
arr = Split(ws1.Cells(ia, "A"), ",").Value
'what should i do after split
Enter the following into a code module...
Function CountWords$(r)
Dim a&, f&, w
For Each w In Split(r, ",")
If w = "alt" Then a = a + 1
If w = "first" Then f = f + 1
Next
If (a + f) Then CountWords = "first-" & f & ",alt-" & a
End Function
Then in cell B2 enter this formula:
=CountWords(A2)
Now copy it downwards as far as you need.
Update
To use the above function from VBA without entering formulas in the worksheet you can do it like this...
Sub Cena()
Dim i&, v
With [a2:a8]
v = .Value2
For i = 1 To UBound(v)
v(i, 1) = CountWords(v(i, 1))
Next
.Offset(, 1) = v
End With
End Sub
Function CountWords$(r)
Dim a&, f&, w
For Each w In Split(r, ",")
If w = "alt" Then a = a + 1
If w = "first" Then f = f + 1
Next
If (a + f) Then CountWords = "first-" & f & ",alt-" & a
End Function
Update #2
In response to your questions in the comments, you can use this variation instead...
Sub Cena()
Dim i&, v
With [a2].Resize(Cells(Rows.Count, 1).End(xlUp).Row - 1)
v = .Value2
For i = 1 To UBound(v)
v(i, 1) = CountWords(v(i, 1))
Next
.Cells = v
End With
End Sub
Function CountWords$(r)
Dim a&, f&, w
For Each w In Split(r, ",")
If w = "alt" Then a = a + 1
If w = "first" Then f = f + 1
Next
If (a + f) Then CountWords = "first-" & f & ",alt-" & a
End Function
In order to make this independent from the words alt and first and whitespaces in the string I would use the following functions
Option Explicit
'Add a reference to Microsoft VBScript Regular Expressions 5.5
Public Function RemoveWhiteSpace(target As String) As String
With New RegExp
.Pattern = "\s"
.MultiLine = True
.Global = True
RemoveWhiteSpace = .Replace(target, vbNullString)
End With
End Function
'Add a reference to Microsoft Scripting Runtime
Function CountWordsA(rg As Range) As String
On Error GoTo EH
Dim dict As Dictionary
Set dict = New Dictionary
Dim vDat As Variant
vDat = RemoveWhiteSpace(rg.Value)
vDat = Split(vDat, ",")
Dim i As Long
For i = LBound(vDat) To UBound(vDat)
If dict.Exists(vDat(i)) Then
dict(vDat(i)) = dict(vDat(i)) + 1
Else
dict.Add vDat(i), 1
End If
Next i
Dim vKey As Variant
ReDim vDat(1 To dict.Count)
i = 1
For Each vKey In dict.Keys
vDat(i) = vKey & "-" & dict(vKey)
i = i + 1
Next vKey
CountWordsA = Join(vDat, ",")
Exit Function
EH:
CountWordsA = ""
End Function
Sub TestIt()
Dim rg As Range
Set rg = Range("A2:A8")
Dim sngCell As Range
For Each sngCell In rg
sngCell.Offset(, 1) = CountWordsA(sngCell)
Next sngCell
End Sub
More about dictionaries and regular expressions
Alternative using Filter() function
This demonstrates the use of the Filter() function to count words via function UBound():
Function CountTerms() (usable also in formulae)
Function CountTerms(ByVal WordList As String, Optional TermList As String = "first,alt", Optional DELIM As String = ",") As String
'Purpose: count found terms in wordlist and return result as list
'[1] assign lists to arrays
Dim words, terms
words = Split(WordList, DELIM): terms = Split(TermList, DELIM)
'[2] count filtered search terms
Dim i As Long
For i = 0 To UBound(terms)
terms(i) = terms(i) & "-" & UBound(Filter(words, terms(i), True, vbTextCompare)) + 1
Next i
'[3] return terms as joined list, e.g. "first-5,alt-1"
CountTerms = Join(terms, ",")
End Function
Example call (due to comment) & help function getRange()
In order to loop over the entire range and replace the original data with the results list:
Sub ExampleCall()
'[1] get range data assigning them to variant temporary array
Dim rng As Range, tmp
Set rng = getRange(Sheet1, tmp) ' << change to sheet's Code(Name)
'[2] loop through array values and get counts
Dim i As Long
For i = 1 To UBound(tmp)
tmp(i, 1) = CountTerms(tmp(i, 1))
Next i
'[3] write to target (here: overwriting due to comment)
rng.Offset(ColumnOffset:=0) = tmp
End Sub
Function getRange(mySheet As Worksheet, tmp) As Range
'Purpose: assign current column A:A data to referenced tmp array
With mySheet
Set getRange = .Range("A2:A" & .Cells(.Rows.Count, 1).End(xlUp).Row)
tmp = getRange ' assign range data to referenced tmp array
End With
End Function
I have a data set that is only 1 column and is pipe delimited
7033 | 6010 | 873
6040 | 888
6017 | 6040 | 567
I am looking for the most efficient way (preferably VBA) to loop through all the rows in the column, and determine if any of the data in row N is equal to row N-1. I would like to be able to insert a value in the adjacent column that flags when this does occur with a "Y" or a "N".
In the example above, Row 2 does not match Row 1 but Row 3 matches Row 2 because of the value "6040"
Any advise or suggestions would be greatly appreciated
Any recommendation
I assume that your data are in column A of Sheet1. This code can be optimized more, but right now it should be fast enough to handle hundreds of lines in seconds
Sub Main()
Dim i As Long
Dim j As Long
Dim str As String
Dim arr As Variant
Dim arr2 As Variant 'array of the result
Dim arrTemp As Variant
Dim rng As Range
'put everything into an array
Set rng = Worksheets("Sheet1").UsedRange.Columns(1)
arr = rng.Value
arr2 = arr
arr2(1, 1) = "" 'delete the first row since there won't be any value above it to compare
'loop thru the array rows and split the values of each element and compare it with the element above it
For i = 2 To UBound(arr, 1)
arrTemp = Split(arr(i, 1), " | ")
arr2(i, 1) = "No" 'assume there is no match at first
For j = 0 To UBound(arrTemp)
If InStr(arr(i - 1, 1), arrTemp(j)) > 0 Then
arr2(i, 1) = "Yes"
Exit For 'there was a match get out
End If
Next j
Next i
'paste the results
rng.Offset(0, 1).Value = arr2
End Sub
Output
Assuming that data is in A Column, Following code will give you the expected output.
Private Sub Test()
Dim i As Integer
For i = 4 To 2 Step -1
j = i - 1
PrevTempStr = Cells(j, "A")
CurTempStr = Cells(i, "A")
PreVal = Split(PrevTempStr, "|") 'Converts into array
CurVal = Split(CurTempStr, "|")
If MatchArray(CurVal, PreVal) Then 'Function to check if any of the element of current array matches with previous array
Cells(i, "B") = "Y" 'Update Value Y in B column if matches
Else
Cells(i, "B") = "N"
End If
Next
End Sub
Private Function MatchArray(Arg1 As Variant, Arg2 As Variant) As Boolean
For i = LBound(Arg1) To UBound(Arg1)
For j = LBound(Arg2) To UBound(Arg2)
If Trim(Arg1(i)) = Trim(Arg2(j)) Then
MatchArray= True
Exit Function
End If
Next j
Next i
MatchArray= False
End Function
I am trying to quickly calculate a long lists unique values given several filters.
Rwave2 generates a range that starts past the end of Rwave, somehow taking values from the original "Export" range.
The first value of s = 44928 and e = 85991 and second value s = 1 and e = 2388. However the second range starts at 89855 of the original "Export" cell Range and 2388 values after. Not 1-2388 of the Rwave range.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
Set KeyCells = Range("B4")
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
Is Nothing Then
Dim wave As String
wave = CStr(Range("B4").Value)
Dim Rwave As Range
Dim s, e As Long
'Separate by Wave
s = Search_Start(Sheets("Export").Range("A:A"), "A", wave)
e = Search_End(Sheets("Export").Range("A:A"), "A", wave, s)
Set Rwave = Sheets("Export").Range(Sheets("Export").Cells(s, "A"), Sheets("Export").Cells(e, "G"))
Sheets("TestSheet1").UsedRange.ClearContents
Rwave.Copy Sheets("TestSheet1").Range("A1")
For i = 6 To 56
'Separate by Zone
Dim Rwave2 As Range
s = Search_Start(Rwave, "B", CStr(Sheets("Sheet1").Cells(i, "B")))
e = Search_End(Rwave, "B", CStr(Sheets("Sheet1").Cells(i, "B")), s)
Set Rwave2 = Rwave.Range(Rwave.Cells(s, "A"), Rwave.Cells(e, "G"))
Sheets("TestSheet2").UsedRange.ClearContents
Rwave2.Copy Sheets("TestSheet2").Range("A1")
'Create an array of only the unique locations
Dim tmp, cell As String
Dim arr() As String
tmp = "|"
For j = 1 To Rwave2.Rows.Count
'Only count the locations on the right level
If Rwave2.Cells(j, "C") = Sheets("Sheet1").Cells(i, "C") Then
cell = Rwave2.Cells(j, "D")
If (cell <> "") And (InStr(tmp, cell) = 0) Then
tmp = tmp & cell & "|"
End If
End If
Next j
If Len(tmp) > 0 Then tmp = Left(tmp, Len(tmp) - 1)
arr = Split(tmp, "|")
Cells(i, "M") = UBound(arr) - LBound(arr)
Next i
End If
End Sub
Function Search_Start(r As Range, c As String, y As String) As Double
For i = 1 To r.Rows.Count
If InStr(r.Cells(i, c), y) <> 0 Then
Search_Start = i
Exit Function
End If
Next i
Search_Start = 1
End Function
Function Search_End(r As Range, c As String, y As String, s As Variant) As Double
For i = s To r.Rows.Count
If InStr(r.Cells(i, c), y) = 0 Then
Search_End = i - 1
Exit Function
End If
Next i
Search_End = r.Rows.Count
End Function
Think I see what's going on now.
The code below will search column C of the range B5:D10.
Because the searched range starts on column B - then column C is the third column, which is column D when looking at the whole worksheet.
Similarly you're counting rows within your range. If worksheet cell D7 contains the word Yellow then it will return i=3 as that's the third row in your range.
Sub Test()
Debug.Print Search_Start(Sheet3.Range("B5:D10"), "C", "Yellow")
End Sub
Function Search_Start(r As Range, c As String, y As String) As Double
Dim i As Long
For i = 1 To r.Rows.Count
Debug.Print r.Cells(i, c).Address
If InStr(r.Cells(i, c), y) <> 0 Then
Search_Start = i
Exit Function
End If
Next i
Search_Start = 1
End Function
To return the correct number use Search_Start = r.Cells(i, c).Row.