Search for cell that contains text and paste value in next blank cell

Question

Im new to VBA and am struggling a bit. I need to search column Q on sheet 2 for the cell that contains “text”, then copy the data in the cell to the right, then paste this value in the next blank cell in column B on sheet1. I have been trying to do this using IF THEN code but keep getting errors. It seems simple but am struggling, can anyone advise? I need the results to post next to week 4, when using .end(XLup) the code runs but posts the results under the 46. When switching to XLdown to run from the top I get an error.

 Sub question68784119()

Const SED As String = "tokyo" 'the text you're searching for"
Dim aCell As Range, wsPull As Worksheet, theCellValue As Variant, wsPaste As Worksheet

    Set wsPull = ThisWorkbook.Sheets("flavors_of_cacao")
    Set wsPaste = ThisWorkbook.Sheets("Sheet1")
    
    For Each aCell In Intersect(wsPull.UsedRange, wsPull.Range("F:G")).Cells
    
        theCellValue = aCell.Value2
        
        If InStr(1, theCellValue, SED, vbTextCompare) > 0 Then
        
            theCellValue = aCell.Offset(0, 1).Value
            wsPaste.Cells(Rows.Count, 5).End(xlDown).Offset(1, 0).Value = theCellValue
        
        End If
        
    Next aCell
    
MsgBox "Done!"

End Sub

The advice would be to share the code, including the errors, you have so far. (sharing the code, means that you use [edit] to improve your question, and copy/paste the TEXT, no images, in your question) — Luuk, Aug 14 '21 at 15:10
Why use VBA when a simple VLookup formula would accomplish what you described? — Chris Maurer, Aug 14 '21 at 17:07
**1.** I would recommend using `.Find` to search for the text. See **Section 4** in [.Find & .FindNext](http://www.siddharthrout.com/index.php/2018/01/05/find-and-findnext-in-excel-vba/). **2.** To paste the data in the next blank cell, find the last row as shown [HERE](https://stackoverflow.com/questions/11169445/error-in-finding-last-used-cell-in-excel-with-vba/11169920#11169920). Give it a try and if you are still stuck then simply post the code that you tried and error messages if any, and we will take it from there. — Siddharth Rout, Aug 15 '21 at 07:25

score 1 · Answer 1 · edited Aug 16 '21 at 16:51

A VBA Lookup

Range.End property
Range.Find method
Optionally, a formula, instead of the value, can be written to the destination cell (each 3rd solution).

Readable:

Sub VBALookupFind()
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim sws As Worksheet: Set sws = wb.Worksheets("Sheet2")
    Dim slRow As Long: slRow = sws.Cells(sws.Rows.Count, "Q").End(xlUp).Row
    If slRow < 2 Then Exit Sub ' no data
    
    Dim slrg As Range
    Set slrg = sws.Range(sws.Cells(2, "Q"), sws.Cells(slRow, "Q"))
    
    Dim slCell As Range
    Set slCell = slrg.Find("text", slrg.Cells(slrg.Cells.Count), _
        xlFormulas, xlWhole)
    If slCell Is Nothing Then Exit Sub ' no match
    
    Dim svCell As Range: Set svCell = slCell.EntireRow.Columns("R")
    
    Dim dws As Worksheet: Set dws = wb.Worksheets("Sheet1")
    Dim dRow As Long: dRow = dws.Cells(dws.Rows.Count, "B").End(xlUp).Row + 1
    Dim dCell As Range: Set dCell = dws.Cells(dRow, "B")
    
    dCell.Value = svCell.Value

End Sub

Sub VBALookupMatch()
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim sws As Worksheet: Set sws = wb.Worksheets("Sheet2")
    Dim slRow As Long: slRow = sws.Cells(sws.Rows.Count, "Q").End(xlUp).Row
    If slRow < 2 Then Exit Sub ' no data
    
    Dim slrg As Range
    Set slrg = sws.Range(sws.Cells(2, "Q"), sws.Cells(slRow, "Q"))
    
    Dim rIndex As Variant: rIndex = Application.Match("text", slrg, 0)
    If IsError(rIndex) Then Exit Sub ' no match
    
    Dim svrg As Range: Set svrg = slrg.EntireRow.Columns("R")
    
    Dim svCell As Range: Set svCell = svrg.Cells(rIndex)
    
    Dim dws As Worksheet: Set dws = wb.Worksheets("Sheet1")
    Dim dRow As Long: dRow = dws.Cells(dws.Rows.Count, "B").End(xlUp).Row + 1
    Dim dCell As Range: Set dCell = dws.Cells(dRow, "B")
    
    dCell.Value = svCell.Value
    
End Sub


Sub VBALookupFormula()
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim sws As Worksheet: Set sws = wb.Worksheets("Sheet2")
    Dim slRow As Long: slRow = sws.Cells(sws.Rows.Count, "Q").End(xlUp).Row
    If slRow < 2 Then Exit Sub ' no data
    
    Dim slrg As Range
    Set slrg = sws.Range(sws.Cells(2, "Q"), sws.Cells(slRow, "Q"))
    
    Dim svrg As Range: Set svrg = slrg.EntireRow.Columns("R")
        
    Dim dws As Worksheet: Set dws = wb.Worksheets("Sheet1")
    Dim dRow As Long: dRow = dws.Cells(dws.Rows.Count, "B").End(xlUp).Row + 1
    Dim dCell As Range: Set dCell = dws.Cells(dRow, "B")
    
    Dim dFormula As String
    dFormula = "=IFERROR(INDEX('" & "Sheet2" _
        & "'!" & svrg.Address(, 0) _
        & "," & "MATCH(""" & "text" _
        & """,'" & "Sheet2" _
        & "'!" & slrg.Address(, 0) _
        & ",0)),"""")"

    dCell.Formula = dFormula

End Sub

Maintainable, Using Constants (Study With Debug.Print)

Sub VBALookupFindConstants()
    
    Const sName As String = "Sheet2" ' Source Worksheet Name
    Const sfRow As Long = 2 ' Source First Row
    Const slCol As String = "Q" ' Source Lookup Column
    Const slValue As String = "text" ' Source Lookup Value
    Const svCol As String = "R" ' Source Value Column
    
    Const dName As String = "Sheet1" ' Destination Worksheet Name
    Const dCol As String = "B" ' Destination Column
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    Dim slRow As Long: slRow = sws.Cells(sws.Rows.Count, slCol).End(xlUp).Row
    If slRow < sfRow Then Exit Sub ' no data
    
    Dim slrg As Range
    Set slrg = sws.Range(sws.Cells(sfRow, slCol), sws.Cells(slRow, slCol))
    Debug.Print "Source Lookup Range Address      " & slrg.Address(, 0)
    
    Dim slCell As Range
    Set slCell = slrg.Find(slValue, slrg.Cells(slrg.Cells.Count), _
        xlFormulas, xlWhole)
    If slCell Is Nothing Then Exit Sub ' no match
    Debug.Print "Source Lookup Cell Address       " & slCell.Address(0, 0)
    
    Dim svCell As Range: Set svCell = slCell.EntireRow.Columns(svCol)
    Debug.Print "Source Value Cell Address        " & svCell.Address(0, 0)
    
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    Dim dRow As Long: dRow = dws.Cells(dws.Rows.Count, dCol).End(xlUp).Row + 1
    Dim dCell As Range: Set dCell = dws.Cells(dRow, dCol)
    Debug.Print "Destination Cell Address         " & dCell.Address(0, 0)
    
    ' Value...
    dCell.Value = svCell.Value
    Debug.Print "Destination Cell Value           " & dCell.Value
    
End Sub

Sub VBALookupMatchConstants()
    
    Const sName As String = "Sheet2" ' Source Worksheet Name
    Const sfRow As Long = 2 ' Source First Row
    Const slCol As String = "Q" ' Source Lookup Column
    Const slValue As String = "text" ' Source Lookup Value
    Const svCol As String = "R" ' Source Value Column
    
    Const dName As String = "Sheet1" ' Destination Worksheet Name
    Const dCol As String = "B" ' Destination Column
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    Dim slRow As Long: slRow = sws.Cells(sws.Rows.Count, slCol).End(xlUp).Row
    If slRow < sfRow Then Exit Sub ' no data
    
    Dim slrg As Range
    Set slrg = sws.Range(sws.Cells(sfRow, slCol), sws.Cells(slRow, slCol))
    Debug.Print "Source Lookup Range Address      " & slrg.Address(, 0)
    
    Dim rIndex As Variant: rIndex = Application.Match(slValue, slrg, 0)
    If IsError(rIndex) Then Exit Sub ' no match
    Debug.Print "Match Index                      " & rIndex
    
    Dim svrg As Range: Set svrg = slrg.EntireRow.Columns(svCol)
    Debug.Print "Source Value Range Address       " & svrg.Address(, 0)
    
    Dim svCell As Range: Set svCell = svrg.Cells(rIndex)
    Debug.Print "Source Value Cell Address        " & svCell.Address(0, 0)
    
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    Dim dRow As Long: dRow = dws.Cells(dws.Rows.Count, dCol).End(xlUp).Row + 1
    Dim dCell As Range: Set dCell = dws.Cells(dRow, dCol)
    Debug.Print "Destination Cell Address         " & dCell.Address(0, 0)
    
    ' Value...
    dCell.Value = svCell.Value
    Debug.Print "Destination Cell Value           " & dCell.Value
    
End Sub


Sub VBALookupFormulaConstants()
    
    Const sName As String = "Sheet2" ' Source Worksheet Name
    Const sfRow As Long = 2 ' Source First Row
    Const slCol As String = "Q" ' Source Lookup Column
    Const slValue As String = "text" ' Source Lookup Value
    Const svCol As String = "R" ' Source Value Column
    
    Const dName As String = "Sheet1" ' Destination Worksheet Name
    Const dCol As String = "B" ' Destination Column
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    Dim slRow As Long: slRow = sws.Cells(sws.Rows.Count, slCol).End(xlUp).Row
    If slRow < sfRow Then Exit Sub ' no data
    
    Dim slrg As Range
    Set slrg = sws.Range(sws.Cells(sfRow, slCol), sws.Cells(slRow, slCol))
    Debug.Print "Source Lookup Range Address      " & slrg.Address(, 0)
    
    Dim svrg As Range: Set svrg = slrg.EntireRow.Columns(svCol)
    Debug.Print "Source Value Range Address       " & svrg.Address(, 0)
    
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    Dim dRow As Long: dRow = dws.Cells(dws.Rows.Count, dCol).End(xlUp).Row + 1
    Dim dCell As Range: Set dCell = dws.Cells(dRow, dCol)
    Debug.Print "Destination Cell Address         " & dCell.Address(0, 0)

    Dim dFormula As String
    dFormula = "=IFERROR(INDEX('" & sName _
        & "'!" & svrg.Address(, 0) _
        & "," & "MATCH(""" & slValue _
        & """,'" & sName _
        & "'!" & slrg.Address(, 0) _
        & ",0)),"""")"
    Debug.Print "Destination Cell Formula         " & dFormula
    
    dCell.Formula = dFormula
    Debug.Print "Destination Cell Value           " & dCell.Value

End Sub

Who downvoted this answer also?!? It works and is informative! — pgSystemTester, Aug 15 '21 at 14:54

score -1 · Accepted Answer · answered Aug 14 '21 at 15:08

You should post whatever attempts you made in your question, but this will do what you specified.

Sub question68784119()
Const tangoText As String = "text" 'the text you're searching for
Dim aCell As Range, wsPull As Worksheet, theCellValue As String, wsPaste As Worksheet

'make sure these are exactly the same as your workbook. Case sensative
    Set wsPull = ThisWorkbook.Sheets("sheet 2")
    Set wsPaste = ThisWorkbook.Sheets("sheet1")
    
    For Each aCell In Intersect(wsPull.UsedRange, wsPull.Range("Q:Q")).Cells
        theCellValue = aCell.Value2
        If InStr(1, theCellValue, tangoText, vbTextCompare) > 0 Then
            aCell.Offset(0, 1).Value2 = theCellValue
            wsPaste.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Value = theCellValue
        End If
    Next aCell

End Sub

thank you! This was extremely helpful. This does exactly what I need, except it is not posting the IF lookup results in the correct cell. I tried switching the XLup to XLdown and got an error, edited the original post to share the issue I am facing. I dont think XLdown is used often? — arisophia, Aug 20 '21 at 19:34

Search for cell that contains text and paste value in next blank cell

2 Answers2

A VBA Lookup