EXCEL - Look up a value in a list and return multiple corresponding values - excel

I am trying to create a Tree Traversal in Excel for a schedule I have. I am at the point where I have 2 lists each 1006 cells long. The first is predecessors, the second is successors. I am trying to use a set of functions to display multiple results. For instance if I enter 3, I want all of the successors of task 3 to get listed. So far the code I have come up with is:
=IF(ISERROR(INDEX($A$1:$B$1006,SMALL(IF($A$1:$A$1006=$E$3,ROW($A$1:$A$1006)),ROW(1:1)),2)),"NO",INDEX($A$1:$B$1006,SMALL(IF($A$1:$A$1006=$E$3,ROW($A$1:$A$1006)),ROW(1:1)),2))
However when I input the predecessor, it does not display the correct successor.
Thank you in advance for whoever can help me

You cannot join values with formulas (or at least, i can't see an easy way to do it).
You can either call a procedure (faster but more intrusive):
Option Explicit
Sub Proc_ListPre()
Dim rData As Range, lLastrow As Long, i As Integer
Dim aValues() As Variant
Dim sFilter As String, sRes As String
'Ask for the value to filter to the user
sFilter = InputBox("Which predecessor do you want to analyse?", "Please type the predecessor you want")
If Len(sFilter) = 0 Then Exit Sub
'Define the range
'either use UsedRange (if only columns A and B are used)
'Set rData = ActiveSheet.UsedRange
'or use End(xlUp) if not
lLastrow = ActiveSheet.Range("a65536").End(xlUp).Row
Set rData = ActiveSheet.Range("A1:B" & lLastrow)
'Filter the predecessor with the criteria given in arg
rData.AutoFilter Field:=1, Criteria1:=sFilter
'Find the last row of the filtered data
lLastrow = ActiveSheet.Range("a65536").End(xlUp).Row
aValues = ActiveSheet.Range("A2:B" & lLastrow).Value
'Join the 2nd column of the array
'Join(WorksheetFunction.Index(aValues, 0, 2), ";") 'note that this doesn't work because index returns a 2D array
'Workaround to join the 2nd column
For i = 1 To UBound(aValues, 1)
If Len(CStr(aValues(i, 2))) > 0 Then
sRes = sRes & aValues(i, 2) & ";"
End If
Next
sRes = Left(sRes, Len(sRes) - 1)
MsgBox sRes
ActiveSheet.AutoFilterMode = False
End Sub
or use a formula that you will call in your worksheet as =ListPre(mypredecessor)
Function ListPre(ByVal sFilter As String)
Dim rData As Range, lLastrow As Long, i As Integer
Dim aValues() As Variant
Dim sRes As String
'Define the range
'either use UsedRange (if only columns A and B are used)
'Set rData = ActiveSheet.UsedRange
'or use End(xlUp) if not
lLastrow = ActiveSheet.Range("a65536").End(xlUp).Row
Set rData = ActiveSheet.Range("A1:B" & lLastrow)
aValues = ActiveSheet.Range("A2:B" & lLastrow).Value
'Join the 2nd column of the array
'Join(WorksheetFunction.Index(aValues, 0, 2), ";") 'note that this doesn't work because it returns a 2D array
'Workaround to join the 2nd column
For i = 1 To UBound(aValues, 1)
If Len(CStr(aValues(i, 2))) > 0 And CStr(aValues(i, 1)) = sFilter Then
sRes = sRes & aValues(i, 2) & ";"
End If
Next
sRes = Left(sRes, Len(sRes) - 1)
ListPre = sRes
End Function

Related

Excel VBA - For Loop IS taking far far too long to execute

First question ever here, I am the newbiest newbie..
So.. what I am trying to get is:
to find if in sheet1 and sheet2 there are cells with the same value on column E from sheet1 and column F from sheet2. if there are, then copy the value from sheet2 column A row x to sheet2 column P row y.
rows x and y are where the identical values are on each sheet.
this is my code:
Sub ccopiazanrfact()
Dim camion As Worksheet
Dim facturi As Worksheet
Set camion = ThisWorkbook.Sheets("B816RUS")
Set facturi = ThisWorkbook.Sheets("EVIDENTA FACTURI")
Dim nrcomanda As String
Dim nrfactura As String
For a = 2 To facturi.Range("F" & Rows.Count).End(xlUp).Row
nrcomanda = facturi.Range("F" & a).Value
For b = 4 To camion.Range("E" & Rows.Count).End(xlUp).Row
If camion.Range("E" & b).Value = facturi.Range("F" & a).Value Then
camion.Range("P" & b) = facturi.Range("A" & a).Value
Exit For
End If
Next b
Next a
End Sub
I would recommend using arrays to achieve what you want. Nested looping over ranges can make it very slow. Is this what you are trying? (UNTESTED). As I have not tested it, I would recommend making a backup of your data before you test this code.
I have commented the code. But if you still have a question or find an error/bug in the below code then simply ask.
Option Explicit
Sub ccopiazanrfact()
Dim Camion As Worksheet
Dim Facturi As Worksheet
Set Camion = ThisWorkbook.Sheets("B816RUS")
Set Facturi = ThisWorkbook.Sheets("EVIDENTA FACTURI")
'~~> Declare 2 arrays
Dim ArCamion As Variant
Dim ArFacturi As Variant
Dim LRow As Long
'~~> Find last row in Col E of Sheets("B816RUS")
LRow = Camion.Range("E" & Camion.Rows.Count).End(xlUp).Row
'~~> Store Values from E4:P last row in the array. We have taken E:P
'~~> because we are replacing the value in P if match found
ArCamion = Camion.Range("E4:P" & LRow).Value
'~~> Find last row in Col E of Sheets("EVIDENTA FACTURI")
LRow = ArFacturi.Range("F" & ArFacturi.Rows.Count).End(xlUp).Row
'~~> Store Values from A2:F last row in the array. We have taken A:F
'~~> because we are replacing the value in P with A
ArFacturi = Facturi.Range("A2:F" & LRow).Value
Dim i As Long, j As Long
For i = 2 To UBound(ArFacturi)
For j = 4 To UBound(ArCamion)
'~~> Checking if camion.Range("E" & j) = facturi.Range("F" & i)
If ArCamion(j, 1) = ArFacturi(i, 6) Then
'~~> Replacing camion.Range("P" & j) with facturi.Range("A" & i)
ArCamion(j, 12) = ArFacturi(i, 1)
Exit For
End If
Next j
Next i
'~~> Write the array back to the worksheet in one go
Camion.Range("E4:P" & LRow).Resize(UBound(ArCamion), 12).Value = ArCamion
End Sub
in the end, I came up with this and works instantly, get’s all the data filled within a blink of an eye. When I tried it first time I thought i forgot to clear the data before running the code:
Sub FindMatchingValues()
'Declare variables for the worksheets
Dim ws1 As Worksheet
Dim ws2 As Worksheet
'Set the variables to refer to the worksheets
Set ws1 = Worksheets("B816RUS")
Set ws2 = Worksheets("EVIDENTA FACTURI")
'Declare variables for the ranges to compare
Dim rng1 As Range
Dim rng2 As Range
'Set the ranges to the columns to compare
Set rng1 = ws1.Range("E1", ws1.Range("E" & Rows.Count).End(xlUp))
Set rng2 = ws2.Range("F1", ws2.Range("F" & Rows.Count).End(xlUp))
'Loop through each cell in the first range
For Each cell1 In rng1
'Use the Match function to find the matching value in the second range
Dim match As Variant
match = Application.match(cell1.Value, rng2, 0)
'If a match was found, copy the value from column A in the second worksheet to column P in the first worksheet
If Not IsError(match) Then
ws1.Range("P" & cell1.Row).Value = ws2.Range("A" & match).Value
End If
Next cell1
End Sub
Please, test the next code. It should be very fast, using arrays and Find function:
Sub ccopiazaNrfact()
Dim camion As Worksheet, facturi As Worksheet, cellMatch As Range, rngE As Range
Set camion = ThisWorkbook.Sheets("B816RUS")
Set facturi = ThisWorkbook.Sheets("EVIDENTA FACTURI")
Set rngE = camion.Range("E4:E" & camion.Range("E" & camion.rows.count).End(xlUp).row)
Dim a As Long, arrFact, arrP, nrComanda As String
arrP = camion.Range("P1:P" & camion.Range("E" & rows.count).End(xlUp).row).Value
arrFact = facturi.Range("A2:F" & facturi.Range("F" & rows.count).End(xlUp).row).Value
Debug.Print UBound(arrP): Stop
For a = 1 To UBound(arrFact)
nrComanda = arrFact(a, 6)
Set cellMatch = rngE.Find(What:=nrComanda, After:=rngE.cells(1, 1), LookIn:=xlValues, lookAt:=xlWhole)
If Not cellMatch Is Nothing Then
arrP(cellMatch.row, 1) = arrFact(a, 1)
End If
Next a
camion.Range("P1").Resize(UBound(arrP), 1).Value = arrP
MsgBox "Ready..."
End Sub
Please, send some feedback after testing it...
A VBA Lookup: Using Arrays and a Dictionary
Option Explicit
Sub CopiazaNrFact()
Dim wb As Workbook: Set wb = ThisWorkbook
' Write the values from the Source Compare and Value ranges to arrays.
' f - Facturi (Source), c - Compare, v - Value
Dim frg As Range, fcData() As Variant, fvData() As Variant, frCont As Long
With wb.Sheets("EVIDENTA FACTURI")
' Compare
Set frg = .Range("F2", .Cells(.Rows.Count, "F").End(xlUp))
frCont = frg.Rows.Count
fcData = frg.Value ' write to array
' Value
Set frg = frg.EntireRow.Columns("A")
fvData = frg.Value ' write to array
End With
' Write the unique values from the Source Compare array to the 'keys',
' and their associated values from the Source Values array to the 'items'
' of a dictionary.
Dim fDict As Object: Set fDict = CreateObject("Scripting.Dictionary")
fDict.CompareMode = vbTextCompare
Dim fr As Long, NrFacturi As String
For fr = 1 To frCont
NrFacturi = CStr(fcData(fr, 1))
If Len(NrFacturi) > 0 Then ' exclude blanks
fDict(NrFacturi) = fvData(fr, 1)
End If
Next fr
' Write the values from the Destination Compare range to an array
' and define the resulting same-sized Destination Value array.
' c - Camion (Destination), c - Compare, v - Value
Dim crg As Range, ccData() As Variant, cvData() As Variant, crCont As Long
With wb.Sheets("B816RUS")
' Compare
Set crg = .Range("E4", .Cells(.Rows.Count, "E").End(xlUp))
crCont = crg.Rows.Count
ccData = crg.Value ' write to array
' Value
Set crg = crg.EntireRow.Columns("P")
ReDim cvData(1 To crCont, 1 To 1) ' define
End With
' For each value in the Destination Compare array, attempt to find
' a match in the 'keys' of the dictionary, and write the associated 'item'
' to the same row of the Destination Value array.
Dim cr As Long, NrCamion As String
For cr = 1 To crCont
NrCamion = CStr(ccData(cr, 1))
If fDict.Exists(NrCamion) Then cvData(cr, 1) = fDict(NrCamion)
Next cr
' Write the values from the Destination Value array
' to the Destination Value range.
crg.Value = cvData
End Sub

Validate the date column whether it is in MMDDYY format or not

In an Excel sheet, one column is with date and we need to validate all the values in that column and check whether they are in MMDDYY format or not. If not, we need to highlight that specific cell with a colour.
Sub effectivedate()
Dim a As Integer
With ThisWorkbook.Sheets("sheet2")
For a = 2 To .Range("e" & Rows.Count).End(xlUp).Row
k = .Range("e" & a)
p = Len(k)
If Application.WorksheetFunction.Count(k) = 1 And p <> 6 Then
.Range("e" & a).Interior.ColorIndex = 6
End If
Next
End With
End Sub
Please, test the next code. It creates the appropriate date from existing Date or String and color the cells keeping text with a length different from 6:
Sub MakeDateMMDDYY()
Dim ws As Worksheet, a As Long, lastR As Long
Dim txtD As String, arr, arrFin, rngCol As Range, colLett As String
colLett = "F" 'the column letter where to be returned the processing result
'if the code returns what you need, you can replade F with E
Set ws = ThisWorkbook.Sheets("sheet2")
lastR = ws.Range("E" & rows.count).End(xlUp).row
arr = ws.Range("E2:E" & lastR).value 'place the range in an array for faster iteration
ReDim arrFin(1 To UBound(arr), 1 To 1) 'redim the array to receive the processing result
For a = 1 To UBound(arr)
txtD = ws.Range("E" & a + 1).text 'place the cell text in a string variable
If Len(txtD) = 6 Then
'create a date from the string and place it in the final array:
arrFin(a, 1) = DateSerial(CLng(Right(txtD, 2)) + 2000, CLng(left(txtD, 2)), CLng(Mid(txtD, 3, 2))): 'Stop
Else
arrFin(a, 1) = txtD 'place the string in the final array
If rngCol Is Nothing Then
Set rngCol = ws.Range(colLett & a + 1) 'first time create the range to be colored
Else
Set rngCol = Union(rngCol, ws.Range(colLett & a + 1)) 'then, use a Union for the next cells to be colored
End If
End If
Next
With ws.Range(colLett & 2).Resize(UBound(arrFin), 1) 'format the range and drop the final array result
.NumberFormat = "MMDDYY"
.value = arrFin
End With
If Not rngCol Is Nothing Then rngCol.Interior.ColorIndex = 6 'color the range keeping the cells to be colored
End Sub

Comparing two lists with different lengths

I want to compare two ID lists with different lengths. The first list is longer and has Values, while the second has no Values.
When the ID's match, it should paste the Value in the first list to the appropriate place beside list 2.
Sub compareList()
Dim v1, v2, v4, v3()
Dim i As Long
Dim j As Long
v1 = Range("A2", Range("A" & Rows.Count).End(xlUp)).Value
v2 = Range("B2", Range("B" & Rows.Count).End(xlUp)).Value
v4 = Range("D2", Range("D" & Rows.Count).End(xlUp)).Value
ReDim v3(1 To 4)
For i = LBound(v1) To UBound(v1)
If IsError(Application.Match(v1(i, 1), v4, 0)) Then
j = j + 1
Else
v3(j) = v2(i, 1)
End If
Next i
Range("E2").Resize(i) = Application.Transpose(v3)
End Sub
It gives me an out of index error, or pastes the value in the order it reads it (without paying attention to the match).
If you do not like Vlookup and need some VBA code, please test the next code:
Sub compareList()
Dim sh As Worksheet, lastR As Long, lastR2 As Long, i As Long, j As Long, arr, arrFin
Set sh = ActiveSheet
lastR = sh.Range("A" & rows.count).End(xlUp).row
lastR2 = sh.Range("D" & rows.count).End(xlUp).row
arr = sh.Range("A2:B" & lastR).Value
arrFin = sh.Range("D2:E" & lastR2).Value
For i = 1 To UBound(arrFin)
For j = 1 To UBound(arr)
If arrFin(i, 1) = arr(j, 1) Then arrFin(i, 2) = arr(j, 2): Exit For
Next j
Next i
sh.Range("D2:E" & lastR2).Value = arrFin
End Sub
Just continuing on and referring to #FaneDuru stating
If you don't like Vlookup and need some VBA code:
1) Example code using Match()
Sub compareListTM()
'define arrays using help function getRange()
Dim arr: arr = getRange(Sheet1.Range("A:A")).Value
Dim data: data = getRange(Sheet1.Range("B:B")).Value
Dim arrFin: arrFin = getRange(Sheet1.Range("D:D")).Value
Dim ret: ret = Application.Match(arrFin, arr, 0) ' Match() items all at once :-)
Dim i As Long
For i = 1 To UBound(ret)
If Not IsError(ret(i, 1)) Then
ret(i, 1) = data(ret(i, 1), 1)
Else
ret(i, 1) = vbNullString
End If
Next i
Sheet1.Range("E2").Resize(UBound(ret), 1).Value = ret
End Sub
If, however you could give VLookUp a try:
2) Example code using worksheetfunction
Sub compareList2()
Dim results
results = WorksheetFunction.VLookup( _
getRange(Sheet1.Range("D:D")), _
getRange(Sheet1.Range("A:B")), _
2, False)
'write results
Sheet1.Range("E2").Resize(UBound(results), 1).Value = results
End Sub
Help function getRange() used in both examples
A way to avoid repeated lastRow, Range definitions in main code.
I don't pretend this function to be perfect in any way, it just meets the necessary requirements for above procedures kept as short as possible.
Function getRange(ColRange As Range, _
Optional ByVal SearchColumn As Variant = 1, _
Optional ByVal StartRow As Long = 2) As Range
'Author : https://stackoverflow.com/users/6460297/t-m
'Purpose: calculate lastrow of a given search column (default: 1st column of ColRange) and
' return ColRange resized to calculated lastrow (considering optional StartRow argument)
'Par. 1 : assumes that ColRange is passed as ENTIRE COLUMN(S) range object, e.g. Range("X:Y")
'Par. 2 : a) a numeric SearchColumn argument refers to the ColRange's column index
' (even outside ColRange, can be negative or higher than columns count in ColRange!)
' b) a literal SearchColumn argument refers to the worksheet column as indicated (e.g. "B")
'Example: getRange(Sheet1.Range("X:Y")) ... calculates lastrow of 1st column in colRange (i.e. in X)
' getRange(Sheet1.Range("X:Y"), "B") ... calculates lastrow of column B in worksheet
'~~~~~~
'1) get columns in ColRange
Dim StartColumn As Long: StartColumn = ColRange.Columns(1).Column
Dim LastColumn As Long: LastColumn = ColRange.Columns(ColRange.Columns.Count).Column
With ColRange.Parent ' i.e. the worksheet
'2) change numeric search column number to letter(s)
If IsNumeric(SearchColumn) Then
If SearchColumn + StartColumn - 1 < 1 Then ' cols left of StartColumn must be at least "A"
SearchColumn = "A"
Else ' get literal column name, e.g. column "D"
SearchColumn = Split((.Columns(SearchColumn + StartColumn - 1).Address(, 0)), ":")(0)
End If
End If
'3) get last row of SearchColumn
Dim lastRow As Long: lastRow = .Range(SearchColumn & .Rows.Count).End(xlUp).Row
If lastRow < StartRow Then lastRow = StartRow ' avoid findings lower than start row
'4) return data range as function result
Set getRange = .Range(.Cells(StartRow, StartColumn), .Cells(lastRow, LastColumn))
End With
End Function

How to use each value in column 1 to add comment (NOTE) from 2 different columns?

I need a dynamic way to add Note in which cell in my ID column A. However the comments need to use the information from Column B and C. ex: ON 01/13/2020, Anne.
I am not sure how to check how many times each value from column A will appear and use information from column D and B to create the comment (NOTE)..
result I need. All the time the ID number will be the same the comments need to be the same as well.
The code I am using is
Sub Cmt_test()
Sheet1.Range("A2").AddComment "On " & Sheet1.Range("D2") & ", " & Sheet1.Range("B2")
End Sub
I don't know how I can make it dynamic to get the information all the time the same ID appears. Maybe if I use Loop on column A would it be possible that all the time the loop finds the same ID to add the comment using the information from column D and B?
Write Comments to Each Cell in a Column
Option Explicit
Sub addComments()
Const wsName As String = "Sheet1"
Const FirstRow As Long = 2
Const LastRowCol As Long = 1 ' or "A"
Const str1 As String = "On "
Const str2 As String = ", "
Dim Cols As Variant: Cols = Array(1, 2, 4)
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
Dim LastRow: LastRow = ws.Cells(ws.Rows.Count, LastRowCol).End(xlUp).Row
Dim Vals As Variant: ReDim Vals(UBound(Cols))
' Define Source Range.
Dim rng As Range: Set rng = ws.Range(ws.Cells(FirstRow, Cols(0)), _
ws.Cells(LastRow, Cols(0)))
' Write Column Ranges to Arrays.
Dim j As Long
For j = 0 To UBound(Cols)
Vals(j) = rng.Offset(, Cols(j) - Cols(0))
Next j
' Loop through elements (rows) of Source Array
' and write comments to a dictionary.
Dim dict As Object, Curr As Variant, i As Long
Set dict = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(Vals(0))
Curr = Vals(0)(i, 1)
If dict(Curr) <> "" Then
dict(Curr) = dict(Curr) & vbLf & str1 _
& Format(Vals(2)(i, 1), "mm/dd/yyyy") & str2 & Vals(1)(i, 1)
Else
dict(Curr) = str1 _
& Format(Vals(2)(i, 1), "mm/dd/yyyy") & str2 & Vals(1)(i, 1)
End If
Next i
' Write comments from the dictionary to Source Range.
rng.ClearComments
Dim cel As Range
For Each cel In rng.Cells
cel.AddComment dict(cel.Value)
Next cel
End Sub

Concatenate the values in one column separated by '/' based on the values assigned to the another column

I have an excel sheet which contains two columns called ProductName and CountryCode.i wanted to concatenate all the CountryCode separated by / based on the corresponding values in the column 'ProductName' and My output would be obtained in a separate column called 'FinalResults'. Please note that I used remove duplicate function to get unique values in Column C from Column A.
I tried the below VBA code with the help of stackoverflow and got the results.
Sub ProductCountry()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet2")
Dim FoundCell As Range, SearchRange As Range, Names As Range, SearchCell As Range
Dim MyString As String, i As Long
Set SearchRange = ws.Range("A2:A" & ws.Range("A" & ws.Rows.Count).End(xlUp).Row)
SearchRange.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ws.Range("C2"), Unique:=True
ws.Range("C2").Delete Shift:=xlShiftUp
Set Names = ws.Range("C2:C" & ws.Range("C" & ws.Rows.Count).End(xlUp).Row)
For Each SearchCell In Names
Set FoundCell = SearchRange.Find(SearchCell)
For i = 1 To Application.WorksheetFunction.CountIf(SearchRange, SearchCell)
MyString = MyString & FoundCell.Offset(, 1) & "/"
Set FoundCell = SearchRange.FindNext(FoundCell)
Next i
SearchCell.Offset(, 1) = Left(MyString, Len(MyString) - 1)
MyString = ""
Next SearchCell
End Sub
Seems it works fine except for the first product PRO1. You could see it didn't concatenate the codes orderly and skipped the country code US and took the country code SG two times instead.
Can anyone help what went wrong in this script and I also got range error sometime if I use this same code for large data.
I rewrote it ...
Public Function ConcatenateCodes(ByVal strProductName As String, ByVal rngCells As Range, Optional ByVal strDelimiter As String = "/") As String
Application.Volatile
Dim objCell As Range, lngRow As Long, lngCol As Long, strThisProductName As String
Dim strCountry As String, lngBlank As Long
For lngRow = 1 To rngCells.Rows.Count
strThisProductName = Trim(rngCells.Cells(lngRow, 1))
strCountry = Trim(rngCells.Cells(lngRow, 2))
If strThisProductName & strCountry = "" Then
lngBlank = lngBlank + 1
Else
lngBlank = 0
If strProductName = strThisProductName Then
ConcatenateCodes = ConcatenateCodes & strDelimiter & strCountry
End If
End If
If lngBlank = 10 Then Exit For
Next
If ConcatenateCodes <> "" Then ConcatenateCodes = Mid(ConcatenateCodes, 2)
End Function
... I'm comfortable with the above but that's just me. It means the data doesn't need to be sorted and it will work.
Add the formula to your cell and watch it go.
If you concern about speed you should use arrays to handle your data:
Option Explicit
Public Sub CollectList()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet2")
'read values into array
Dim InputValues() As Variant
InputValues = ws.Range("A2", ws.Cells(ws.Rows.Count, "A").End(xlUp).Offset(0, 1)).Value
Dim UniqueList As Object
Set UniqueList = CreateObject("Scripting.Dictionary")
'collect all products in a dictionary
Dim iRow As Long
For iRow = 1 To UBound(InputValues, 1)
If UniqueList.Exists(InputValues(iRow, 1)) Then
UniqueList(InputValues(iRow, 1)) = UniqueList(InputValues(iRow, 1)) & "/" & InputValues(iRow, 2)
Else
UniqueList.Add InputValues(iRow, 1), InputValues(iRow, 2)
End If
Next iRow
'output dictionary into cells
iRow = 2 'start output in row 2
Dim itm As Variant
For Each itm In UniqueList
ws.Cells(iRow, "C").Value = itm
ws.Cells(iRow, "D").Value = UniqueList(itm)
iRow = iRow + 1
Next itm
End Sub
As can be seen by the other responses, there are many ways to accomplish your task.
But read VBA HELP for the Range.Find method
I submit the following to help you understand where you went wrong:
This is your problem line:
Set FoundCell = SearchRange.Find(SearchCell)
You only specify the what argument for the Find. So other arguments default to some uncontrolled value. In general, the after argument will default to the beginning of the range, so the first matching term you will Find for PRO1 will be in A3. Also, the 2nd SG is being picked up because the lookat is defaulting to xlPart and PRO1 is contained within PRO10.
So one way of correcting that portion of your code, would be to be sure to specify all the relevant arguments of the Find. eg:
Set FoundCell = SearchRange.Find(what:=SearchCell, after:=SearchRange.End(xlDown), lookat:=xlWhole)

Resources