Find text in one cell and add data to the cell below it

[draculadave]

Hi,

I have a spreadsheet that has data in every other row, 800 columns wide. I want to be able to look up a specific string of text in the entire sheet and, once it is located, be able to enter data to the cell directly below it. So, if the text in the sheet said Fluffy, I want to be able to search for the word Fluffy and then be able to enter the word cat underneath it. Each word that I search for will need to have a different word beneath it. I have been doing this manually, but, ****. I have tried doing this using Search and Replace as part of a macro, but it always takes me back to the specific cell that I was in when I recorded the macro. Any help would be greatly appreciated.

 

[Peter_SSs]

Welcome to the MrExcel board!

It is not clear

• where the string(s) to search for are to be found
• where the string(s) to put under are found
• whether the string(s) being searched for might occur multiple times in the sheet & if so whether the other string is put under just one of the found strings or under every occurrence
• whether the string(s) being searched for would be the only thing in the cell. For example, if searching for cat, would something be put underneath if the cell contained "Scattered cows"?

However, this might get you started. The list of things to search for and what to put under are built into the code and this particular code will just put something under one occurrence of the found string. The code looks for cells that contain the searched for string and nothing else.

Test with a copy of your data.

Sub FindAndAddBelow()
  Dim aFind As Variant, aBelow As Variant
  Dim rFound As Range
  Dim i As Long
 
  aFind = Array("Fluffy", "Hairy", "Big")   '<- List of strings to search for
  aBelow = Array("cat", "dog", "elephant")  '<- List of strings to put under
 
  For i = LBound(aFind) To UBound(aFind)
    Set rFound = Cells.Find(What:=aFind(i), LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
    If rFound Is Nothing Then
      MsgBox aFind(i) & " not found"
    Else
      rFound.Offset(1).Value = aBelow(i)
    End If
  Next i
End Sub

 

[draculadave]

I am not sure what you mean by where the strings are to be found or put under, but I attached two small pictures of the worksheet. I need to search for the numbers in green (Example 1), which can occur multiple times throughout the worksheet, and place a different number underneath it, for every occurrence of the number in green. So, for example, in the picture that I attached, I need to find 959186 each time that it appears, and put the number 647 under every occurrence of 959186 (Example 2). I hope that makes sense.

 

[rlv01]

A slightly different approach. Keep in mind that this example searches every cell in the active sheet's used range. If you want the search range to be constrained or limited in some other way, you'll need to define that.

Sub FindAndAdd()
    Dim R As Range
    Dim FirstAddr As String, SearchStr As String, SearchWordAddPairs As String, AddStr As String
    Dim MatchCnt As Long, I As Long
    Dim SearchArr As Variant
    
    'Comma delimited string to define [Searchword;addword] pairs
    SearchWordAddPairs = "Fluffy;cat,Hairy;dog,Big;elephant,959186;647"

    SearchArr = Split(SearchWordAddPairs, ",")
    For I = 0 To UBound(SearchArr)
        MatchCnt = 0
        SearchStr = Split(SearchArr(I), ";")(0)
        AddStr = Split(SearchArr(I), ";")(1)

        With ActiveSheet.UsedRange
            Set R = .Find(what:=SearchStr, after:=.Cells(.Cells.Count), lookat:=xlWhole, MatchCase:=False, searchdirection:=xlNext)
            If Not R Is Nothing Then
                FirstAddr = R.Address
                MatchCnt = MatchCnt + 1
            End If
            Do While Not R Is Nothing
                Set R = .Find(what:=SearchStr, after:=R, lookat:=xlWhole, MatchCase:=False, searchdirection:=xlNext)
                If Not R Is Nothing Then
                    MatchCnt = MatchCnt + 1
                    R.Offset(1).Value = AddStr
                End If
                If R.Address = FirstAddr Then
                    MatchCnt = MatchCnt - 1
                    Set R = Nothing
                    Exit Do
                End If
            Loop
        End With
    Next I
End Sub

Book3
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P
1	100	100	Fluffy	100	100	100	100	100	100	100	100	100	100	100	100	100
2			cat
3	100	100	100	100	100	100	Hairy	100	100	100	100	100	100	100	100	100
4							dog
5	100	100	100	100	100	100	100	Hairy	100	100	100	Big	100	100	100	100
6								dog				elephant
7	100	100	Hairy	100	100	Fluffy	100	100	Fluffy	100	100	100	100	100	100	Fluffy
8			dog			cat			cat							cat
9	100	100	100	100	100	Fluffy	100	100	100	Hairy	100	Big	100	100	100	100
10						cat				dog		elephant
11	100	100	100	Big	100	100	100	100	100	100	100	100	100	100	100	100
12				elephant
13	100	100	100	100	100	Fluffy	100	100	959186	100	100	100	100	100	100	100
14						cat			647
15	Big	100	100	100	100	100	100	100	100	100	959186	100	100	100	100	Big
16	elephant										647					elephant
17	100	100	100	100	100	100	Big	100	100	100	100	100	100	100	100	100
18							elephant
19	100	100	100	100	100	100	100	100	100	100	100	100	100	100	100	100
Sheet1

 

[Peter_SSs]

I am not sure what you mean by where the strings are to be found or put under,

In your first post it was Fluffy/cat in your second post it was 959186/647. What I meant was how do we know which of those (or something else) it actually is and is there more than one pair?
And where does the code find the values? eg In the code itself like @rlv01 and I did or perhaps the values are listed in some cells in the workbook somewhere?

In any case this would be the adaptation of my earlier code for the example given.

Sub FindAndAddBelow_v2()
  Dim sFind As String, sBelow As String, sFirstAddr As String
  Dim rFound As Range
  
  sFind = "959186"    '<- String to search for
  sBelow = "647"      '<- String to put under
  Set rFound = Cells.Find(What:=sFind, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
  If rFound Is Nothing Then
    MsgBox sFind & " not found"
  Else
    Application.ScreenUpdating = False
    sFirstAddr = rFound.Address
    Do
      rFound.Offset(1).Value = sBelow
      Set rFound = Cells.Find(What:=sFind, After:=rFound, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
    Loop Until rFound.Address = sFirstAddr
    Application.ScreenUpdating = True
  End If
End Sub

 

[draculadave]

rlv01 and Peter_SSs​

Both of your solutions worked perfectly for what I needed. I did need to search the entire worksheet and the numbers that I was searching are unique within each cell. I really cannot express my gratefulness for your help. You have saved me thousands of hours of work. I am so happy now. Thank you both. I can only mark one as having solved the problem, and it does not seem fair to only mark one of your responses when they both solved the problem.

 

[Peter_SSs]

Both of your solutions worked perfectly for what I needed. I did need to search the entire worksheet and the numbers that I was searching are unique within each cell. I really cannot express my gratefulness for your help. You have saved me thousands of hours of work. I am so happy now. Thank you both.

You are welcome. Glad we could help. Thanks for the follow-up.

I can only mark one as having solved the problem, and it does not seem fair to only mark one of your responses when they both solved the problem.

The solution mark is to help future readers/searchers of the forum not to boost out egos so it doesn't matter which one you mark. You can mark the one you went with (maybe one seemed like you understood it better or you think you could modify it better in the future if needed?) or all being equal you could mark post #4 since @rlv01 got in before me.

 

[rlv01]

I can only mark one as having solved the problem, and it does not seem fair to only mark one of your responses when they both solved the problem.

Don't worry about it, no one is keeping score. I'm glad you got a solution . @Peter_SSs was the first to reply so you can mark down his post as the solution.