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