VBA to look up criteria in one column and return values from another column

[cjcass]

Hi,

I'm looking for a VBA solution that will:

1. Look at the value in cell G7 in the sheet named "Criteria" (it will be a string of simple text, eg. Black Cat).
2. Then go to the Range E4:E1000 in the sheet named "Info" and find every instance that matches the value in G7 on the "Criteria" sheet.
3. Then return all the values in the Range F4:F1000 in the sheet named "Info" that are adjacent to the matching values found in the Range E4:E1000.
4. The values need to be returned into cell C6 downwards in sheet "Criteria" as one block, ie. no empty rows.

Hopefully this makes sense.
Any help much appreciated.

 

[JoeMo]

Untested - try on a copy of your workbook.

Sub cjcass()
Dim wsht1 As Worksheet, Wsht2 As Worksheet
Dim LookFor As String, Rinfo As Range, Rfnd As Range, Output() As Variant, Ct As Long
Set wsht1 = Sheets("Criteria"): Set Wsht2 = Sheets("Info")
LookFor = wsht1.Range("G7").Value: Set Rinfo = Wsht2.Range("E4:E1000")
With Rinfo
    Set Rfnd = .Find(what:=LookFor, LookIn:=xlValues, lookat:=xlWhole, MatchCase:=True)
    If Rfnd Is Nothing Then
        MsgBox "The search criteria " & LookFor & " is not found - exiting sub"
        Exit Sub
    Else
        adr = Rfnd.Address
    End If
    Do
        Ct = Ct + 1
        ReDim Preserve Output(1 To Ct)
        Output(Ct) = Rfnd.Offset(0, 1).Value
        Set Rfnd = .FindNext(Rfnd)
        If Rfnd Is Nothing Then Exit Do
        If Rfnd.Address = adr Then Exit Do
    Loop
End With
wsht1.Range("C6").Resize(Ct, 1).Value = Application.Transpose(Output)
End Sub

 

[cjcass]

Untested - try on a copy of your workbook.

Sub cjcass()
Dim wsht1 As Worksheet, Wsht2 As Worksheet
Dim LookFor As String, Rinfo As Range, Rfnd As Range, Output() As Variant, Ct As Long
Set wsht1 = Sheets("Criteria"): Set Wsht2 = Sheets("Info")
LookFor = wsht1.Range("G7").Value: Set Rinfo = Wsht2.Range("E4:E1000")
With Rinfo
    Set Rfnd = .Find(what:=LookFor, LookIn:=xlValues, lookat:=xlWhole, MatchCase:=True)
    If Rfnd Is Nothing Then
        MsgBox "The search criteria " & LookFor & " is not found - exiting sub"
        Exit Sub
    Else
        adr = Rfnd.Address
    End If
    Do
        Ct = Ct + 1
        ReDim Preserve Output(1 To Ct)
        Output(Ct) = Rfnd.Offset(0, 1).Value
        Set Rfnd = .FindNext(Rfnd)
        If Rfnd Is Nothing Then Exit Do
        If Rfnd.Address = adr Then Exit Do
    Loop
End With
wsht1.Range("C6").Resize(Ct, 1).Value = Application.Transpose(Output)
End Sub

Works beautifully, thank you very much indeed

 

[Joe4]

When marking a reply as the solution, please mark the post that originally contained the solution, not your own post acknowledging that some other post is the solution.
I have gone ahead and updated this for you.

 

[JoeMo]

Works beautifully, thank you very much indeed

You are welcome - thanks for the reply.