Macro - Find text and copy and paste cell below - loop in row

[tinylitledragon]

hello good people,
please help me. my problem is:

Let´s say sheet - "delivery" - has a row1 that includes all possible delivery days. So A1 is 1.9.2013, B1 is 15.9.2013, C1 is 1.10.2013 and so on.
I want to make a macro, that will gradually go through whole row 3 in sheet "delivery" and look for "A1" date in sheet "Orders". Sheet "orders" have for example in column B the date of delivery, and in column C product of the delivery.
I want the macro to find all deliveries with "A1" date, and paste all products that will be delivered on this day under cell A1 (sheet delivery). then move on to the cell B1 (sheet delivery) - find all orders in sheet orders, that will be delivered on B1 date, and list all products with this delivery date under cell B1 (sheet delivery).

Example:
Sheet order[TABLE="width: 500"]
<tbody>[TR]
[TD]A[/TD]
[TD]B[/TD]
[TD]C[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Date of delivery[/TD]
[TD]Product[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]1.9.2013[/TD]
[TD]orange[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]1.10.2013[/TD]
[TD]paper[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]1.9.2013[/TD]
[TD]pencil[/TD]
[/TR]
</tbody>[/TABLE]

Sheet delivery

[TABLE="width: 500"]
<tbody>[TR]
[TD]1.9.2013[/TD]
[TD]15.9.2013[/TD]
[TD]1.10.2013[/TD]
[/TR]
[TR]
[TD]orange[/TD]
[TD][/TD]
[TD]paper[/TD]
[/TR]
[TR]
[TD]pencil[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]


Can anybody help? Unfortunately simple Pivot table is not able to do this simple list.
Thank you!

 

[patel45]

in the first row of Sheet delivery I see 15.9.2013, is not present in Sheet order

 

[zhfgtj27]

Assuming your date of delivery is in Column A and product in Column B in sheet "orders".

Sub Delivery()
Dim lC As Long, cel As Range, r As Long
lC = ActiveWorkbook.Worksheets("delivery").UsedRange.Columns.Count
For Each cel In ActiveWorkbook.Worksheets("orders").Range("A2:A" & Worksheets("orders").UsedRange.Rows.Count)
For i = 1 To lC
If cel.Value = ActiveWorkbook.Worksheets("delivery").Cells(1, i).Value Then
ActiveWorkbook.Worksheets("delivery").Cells(ActiveWorkbook.Worksheets("delivery").Cells(Rows.Count, i).End(xlUp).Row + 1, i) = _
cel.Offset(0, 1).Value
End If
Next i
Next cel
End Sub

 

[tinylitledragon]

Hello!
thank you for the macro, I had to adjust it a little bit so it fits to my table (position of the cells), but basically it worked. THANK YOU! Here is the adjusted macro:

Sub delivery()


Dim ws As Worksheet
Dim ws3 As Worksheet


Set ws = Sheets("Order")
Set ws3 = Sheets("Delivery")


Dim lC As Long, cel As Range, r As Long
lC = Sheets("Delivery").UsedRange.Columns.Count
For Each cel In Sheets("Order").Range("M3:M" & Sheets("Order").UsedRange.Rows.Count)
For i = 2 To lC
If cel.Value = Sheets("Delivery").Cells(2, i).Value Then
Sheets("Delivery").Cells(Sheets("Delivery").Cells(Rows.Count, i).End(xlUp).Row + 1, i) = _
cel.Offset(0, -12).Value
End If
Next i
Next cel
End Sub

Anyway, thank you VERY MUCH for your help.