С такими данными, как:
Запуск этого макроса:
Sub prodList()
Dim cust As String, rLook As Range, msg As String
Dim ct As Variant, r As Range
cust = Application.InputBox(Prompt:="Enter Customer Name", Type:=2)
Set rLook = Range("1:1").Find(What:=cust, After:=Range("A1")).EntireColumn
msg = ""
For Each r In rLook.Cells
pr = Cells(r.Row, 1).Value
If pr = "" Then Exit For
ct = CStr(r.Value)
If ct <> "" Then
msg = msg & vbCrLf & pr & vbTab & ct
End If
Next r
MsgBox msg
End Sub
Будет отображать:
EDIT # 1:
Для сохранения вывода на Sheet2 используйте этот макрос:
Sub prodList2()
Dim cust As String, rLook As Range, K As Long
Dim ct As Variant, r As Range
cust = Application.InputBox(Prompt:="Enter Customer Name", Type:=2)
Set rLook = Range("1:1").Find(What:=cust, After:=Range("A1")).EntireColumn
K = 1
For Each r In rLook.Cells
pr = Cells(r.Row, 1).Value
If pr = "" Then Exit For
ct = CStr(r.Value)
If ct <> "" Then
Sheets("Sheet2").Cells(K, 1) = pr
Sheets("Sheet2").Cells(K, 2) = ct
K = K + 1
End If
Next r
End Sub