Copy 2 Columns of Data from Sheet1 and Paste in Sheet2

Try

Sub test()
    Dim a, e, p, v, x, i As Long, ii As Long, n As Long
    With Sheets("sheet1").Cells(1).CurrentRegion
        x = Filter(.Parent.Evaluate("transpose(if(" & .Columns(2).Address & "=""Tall"",row(" & .Address & ")))"), False, 0)
        If UBound(x) > -1 Then a = Application.Index(.Value, Application.Transpose(x), [{4,14,18,24,25,26,27,28,29}])
    End With
    If UBound(x) = -1 Then MsgBox "No Tall in Col.B": Exit Sub
    ReDim p(1 To UBound(a, 1) * 9, 1 To 1), v(1 To UBound(p, 1), 1 To 1)
    For ii = 2 To UBound(a, 2)
        For i = 1 To UBound(a, 1)
            n = n + 1
            p(n, 1) = a(i, 1): v(n, 1) = a(i, ii)
    Next i, ii
    Sheets("sheet2").[p2].Resize(n).Value = p
    Sheets("sheet2").[v2].Resize(n).Value = v
End Sub

Change to

Sub oranges_fee()
 Dim a, e, p, t, v, x, i As Long, ii As Long, n As Long
    With Sheets("sheet1").Cells(1).CurrentRegion
        x = Filter(.Parent.Evaluate("transpose(if(" & .Columns(2).Address & "=""Tall"",row(" & .Address & ")))"), False, 0)
        If UBound(x) > -1 Then a = Application.Index(.Value, Application.Transpose(Split("1," & Join(x, ","), ",")), [{4,14,18,24,25,26,27,28,29}])
    End With
    If UBound(x) = -1 Then MsgBox "No Tall in Col.B": Exit Sub
    ReDim p(1 To UBound(a, 1) * 9, 1 To 1), v(1 To UBound(p, 1), 1 To 1), t(1 To UBound(p, 1), 1 To 1)
    For ii = 2 To UBound(a, 2)
        For i = 2 To UBound(a, 1)
            n = n + 1: p(n, 1) = a(i, 1)
            t(n, 1) = a(1, ii): v(n, 1) = a(i, ii)
    Next i, ii
    Sheets("sheet2").[p2].Resize(n).Value = p
    Sheets("sheet2").[t2].Resize(n).Value = t
    Sheets("sheet2").[v2].Resize(n).Value = v
End Sub