Copy rows

[Martin]

I'm trying to write a macro, that copy rows from sheet 2 to sheet 1
and the criteria for the rows in sheet 2 comes from sheet 3.
I'm very new to VBA, so I'm trying to piece different macros
together but can't get to do right.

Example:
Sheet 3 (performance sheet)
Stock no. 10 20 24 30
No. sold

Sheet 2 (inventory list)
Stock no. amount on stock. Amount sold
10 10 0
11 5 5
20 3 5
21 2 3
24 9 1
30 1 2
35 10 2

Result:
sheet 1
Stock no. amount on stock. Amount sold
10 5 5
20 3 5
24 9 1
30 1 2

I have a macro that kind of works, but it is very slow and if a number
doesn't exist in sheet 1, it stops with an error.
The numbers of criterias in sheet 3 varies so I need a loop, that runs
x numbers of time.

Could anyone help me please ?

 

[Martin]

I have used the macro from http://www.rondebruin.nl/copy5.htm added a
loop macro

Sub makro()
' This sub use the function LastRow
Dim WS1 As Worksheet
Dim WS2 As Worksheet
Dim WS3 As Worksheet
Dim rng1 As Range
Dim rng2 As Range
Dim str As Long

Set WS1 = Sheets("Ark2") '<<< Change
Set WS2 = Sheets("Ark1") '<<< Change
Set WS3 = Sheets("Ark3") '<<< Change
Set rng1 = WS1.Range("A1").CurrentRegion '<<< Change 'A1 is the
top left cell of your filter range and the header of the first column

Range("B7").Select
' loop
Dim CountA As Range
Set CountA = WS3.Range("G2")

l_loop = 0
Do Until l_loop = CountA
l_loop = l_loop + 1

Sheets("ark3").Select
ActiveCell(1, 2).Select '<<< NExt column

str = ActiveCell.Value

'Close Auto
WS1.AutoFilterMode = False

'This example filter on the first column in the range (change the
field if needed)
rng1.AutoFilter Field:=1, Criteria1:=str, Operator:=xlOr

With WS1.AutoFilter.Range
On Error Resume Next
' This example will not copy the header row
Set rng2 = .Offset(1, 0).Resize(.Rows.Count - 1,
..Columns.Count) _
.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not rng2 Is Nothing Then
'Copy the cells
rng2.Copy WS2.Range("A" & LastRow(WS2) + 1)
'Delete the rows in WS1
rng2.EntireRow.Delete

End If
End With
WS1.AutoFilterMode = False

Loop


End Sub
Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlValues, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row

On Error GoTo 0
End Function