Find text and copy VBA Code

[fari1]

i've a code, that finds some particular text and trims the rows and paste them in a separate sheet.

i want to amend the code to do the following ,


my first column contains some particular text that is Apple, Bat, Cat, Deer,Ear and the 3rd column contains some description of it, for each row in Column 1 against Text A, there are two row values and i want the 2nd row value, explained below

Columns 1-------------- 2------------ 3------------- 4
Row
---------A----------------------- Apple Fruit
--------------------------------Its is used in food
---------B -----------------------Bat Sports
--------------------------------its used in playing
---------C----------------------- Cat Animal
-----------------------------------its a pet
---------D -----------------------Deer Animal
--------------------------------its found in zoo
---------E -----------------------Ear Body Part
-----------------------------------used to hear

i need every 2nd cell value from column C, which are against apple ,Cat and Ear, e.g in this case, its used in food,its a pet,used to hear and copy them in sheet2

i've a code for this, but first it is based upon anyotrher criteria,2nd its a loop, which i dun want,3rd it is quiet long.

Sub test()
Dim LastRow As Long
Dim shin As Worksheet
Set shin = Sheets("info")
shin.Select
LastRow = [a65536].End(xlUp).Row
For i = LastRow To 22 Step -1
 
    shin.Cells(i, "a").Value = RTrim(Cells(i, "a").Value)
    Select Case shin.Cells(i, "a").Value
        Case "Bat"
        'nothing
        Case "Cat"
        'nothing
        Case "Deer"
        'nothing
        Case "Ear"
        'nothing
        Case ""
        'nothing
        Case Else
        Rows(i & ":" & i + 1).Delete
    End Select
Next i
Call test2
Call Macro1
Call iblank
 
End Sub
 
 
Sub test2()
Dim LastRow As Long
Dim shin As Worksheet
Set shin = Sheets("info")
shin.Select
LastRow = [a65536].End(xlUp).Row
For i = LastRow To 22 Step -1
    shin.Cells(i, "a").Value = RTrim(Cells(i, "a").Value)
    Select Case shin.Cells(i, "a").Value
        Case ""
        'nothing
        Case Else
        Rows(i).Delete
    End Select
Next i
End Sub
Sub Macro1()
Dim i As Long
Dim j As Long
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Set sh1 = Sheets("info")
Set sh2 = Sheets("filter")
i = sh1.Cells(sh1.Rows.Count, "C").End(xlUp).Row
sh1.Cells(22, "C").Resize(i - 21).copy
sh2.Range("A20").PasteSpecial Paste:=xlPasteValues
sh2.Range("A" & (i - 1) & ":A" & sh2.Rows.Count).ClearContents
End Sub
Sub iblank()
Dim j As Long
Dim sh2 As Worksheet
Dim sh3 As Worksheet
Dim k(), ka, i As Long, n As Long
Set sh2 = Sheets("filter")
Set sh3 = Sheets("URLs")
j = sh2.Cells(sh2.Rows.Count, "G").End(xlUp).Row
sh3.Columns("A:D").ClearContents
sh3.UsedRange.Columns(1).Offset(1).ClearContents
ka = sh2.Cells(20, "G").Resize(j - 19)
ReDim k(1 To UBound(ka, 1), 1 To 1)
For i = 1 To UBound(ka, 1)
    If Len(WorksheetFunction.Trim(ka(i, 1))) Then
        n = n + 1
        k(n, 1) = ka(i, 1)
    End If
Next
sh3.Range("a2").Resize(n).Value = k
End Sub