Try this....

Sub TEST()
Dim i, j As Integer
Dim ValName As String
i = 2
j = 2
ValName = Sheets("Sheet2").Cells(1, 2)
Sheets("SHEET2").Range("A:b").ClearContents
Sheets("Sheet2").Cells(1, 1) = "PRODUCT"
Sheets("Sheet2").Cells(1, 2) = ValName

Do Until Sheets("sheet1").Cells(i, 1) = "" Or Sheets("sheet1").Cells(i, 1) = Null
If ValName = Sheets("Sheet1").Cells(i, 1) Then
Sheets("Sheet2").Cells(j, 1) = Sheets("Sheet1").Cells(i, 1)
Sheets("Sheet2").Cells(j, 2) = Sheets("Sheet1").Cells(i, 2)
j = j + 1
End If
i = i + 1
Loop

End Sub

Best regards,
Kaiyasit Phanmakorn
kaiyasitp@gmail.com

Hi Kaiyasit,
I tried with Find method. Pls refer the code below...
Am not able to get the respective amount from 'D' column of sheet1("Data") for the description matched in 'C' column of sheet1("Data"). In sheet2("Result"), description is displayed properly but the corresponding amount for the matched description does not display.. Please help me out :(

On Error Resume Next
Set WB = ActiveWorkbook
If Err = 0 Then
On Error GoTo 0
For Each WS In WB.Worksheets
'Omit results page from search
'If WS.Name <> "Result" Then
If WS.Name = "Data" Then
With WB.Sheets(WS.Name).Cells
Set Cell = .Find(What:=Search, after:=.SpecialCells(xlCellTypeLastCell), LookIn:=xlValues, LookAt:=xlPart, _
MatchCase:=False, SearchOrder:=xlByColumns)

If Not Cell Is Nothing Then
FirstAddress = Cell.Address
Do
Counter = Counter + 1

ReDim Preserve FindCell(1 To Counter)
ReDim Preserve FindSheet(1 To Counter)
ReDim Preserve FindWorkBook(1 To Counter)
ReDim Preserve FindPath(1 To Counter)
ReDim Preserve FindText(1 To Counter)
ReDim Preserve FindAmount(1 To Counter)
FindCell(Counter) = Cell.Address(False, False)
' MsgBox FindCell(Counter)
FindText(Counter) = Cell.Text
' FindAmount(Counter) = Worksheets("Data").Range("D3:D1000").Cells(Counter, 1).Value
FindCell(Counter) = Cell.Address(False, False)
' MsgBox FindCell(Counter)
FindAmount(Counter) = Cell(counter,2).Value
' MsgBox FindAmount (Counter)
FindSheet(Counter) = WS.Name
FindWorkBook(Counter) = WB.Name
FindPath(Counter) = WB.FullName
Set Cell = .FindNext(Cell)
Loop While Not Cell Is Nothing And Cell.Address <> FirstAddress
End If
End With
End If
Next
End If

It's may be not good code.....
Please try......and feed back


Private Sub AMOUNT_()
On Error GoTo AMOUNT_Error
Dim Desc() As String
Dim Amount() As Long
Dim i, j, jj, jjj, k, m, l As Integer

Sheets("Result").Cells(1, 1) = "DESC"
Sheets("Result").Cells(1, 2) = "AMOUNT_"
i = 2
'Count row
Do Until Sheets("Data").Cells(i, 3) = "" Or Sheets("Data").Cells(i, 3) = Null
i = i + 1
Loop


ReDim Desc(2 To i)
ReDim Amount(2 To i)


jjj = 2

'get Desc type
For j = 2 To i
For jj = 2 To i
If Sheets("Data").Cells(j, 3) = Desc(jj) Or IsNull(Sheets("Data").Cells(j, 3)) Or Sheets("Data").Cells(j, 3) = "" Then GoTo Jum1
Next jj

Desc(jjj) = Sheets("Data").Cells(j, 3)
jjj = jjj + 1

Jum1:
Next j

'Sum Data
For m = 2 To jjj - 1
For k = 2 To i
If Desc(m) = Sheets("Data").Cells(k, 3) Then
Amount(m) = Amount(m) + Val(Sheets("Data").Cells(k, 4))
End If
Next k
'show Data to Resulted
Sheets("Result").Cells(m, 1) = Desc(m)
Sheets("Result").Cells(m, 2) = Amount(m)
Next m
Exit Sub
AMOUNT_Error:
MsgBox Err.Description & " - " & Err.Number
End Sub