Hjælp til makro til automatisering

Nedenstående er i hvert tilfælde et forsøg:

Sub KopierFiltrerOgGem()
    Workbooks.Add
    Workbooks("Mappe1").Sheets("Ark1").Range("A1:K6").AdvancedFilter Action:= _
        xlFilterCopy, CriteriaRange:=Workbooks("Mappe1").Sheets("Ark1").Range("M1:N2" _
        ), CopyToRange:=Range("A1"), Unique:=False
    ActiveWorkbook.SaveAs FileName:="U:\Amomobil.xls", FileFormat:=xlNormal, _
        Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
        CreateBackup:=False
End Sub

Der skal måske lige en lille forklaring til. Makroen er baseret på et avanceret filter, hvor kriteriefunktionen er placeret i cellerne M1:N2 på samme ark som data findes. Det kan du selvfølgelig ændre efter behov.

I M1:N2 har jeg skrevet

M1: Test    N1:Test
M2: >=10000  N2: <11000

"Test" skal være den samme overskrift som du bruger i A kolonnen.

"Mappe1", "Ark1" etc. kan du selvfølgelig ændre til dine navne.

mile -> lige et par spm.
er det "rigtige" tal du har i kolonne A eller snige der sig bogstaver med?
vil tallene der skal søges på altid være mellem 10000 og 11000 eller skal 1023 også kopieres.
mener du det med at rækkerne skal være markerede?

Prøv denne her:
----------------

Public Sub KopierOgGem()

Dim maxRow As Integer
Dim i As Integer
Dim antalFundet As Integer

Dim nytArk As Workbook
Dim originaleArk As Workbook
Dim A As Variant

maxRow = ActiveSheet.UsedRange.Rows.Count
antalFundet = 0

Set originaleArk = ActiveWorkbook

Set nytArk = Workbooks.Add
originaleArk.Activate

Application.ScreenUpdating = False
For i = 1 To maxRow
    If Left((Cells(i, 1)), 2) = 10 Then
        antalFundet = antalFundet + 1
        Range(Cells(i, 1), Cells(i, 11)).Copy
        nytArk.Activate
        Range(Cells(antalFundet, 1), Cells(antalFundet, 11)).Select
        ActiveSheet.Paste
        originaleArk.Activate
    End If
Next i
Application.ScreenUpdating = True

nytArk.SaveAs "C:\Amomobil.xls"  ' Ændres til U:\

End Sub
--------------------

Bak det er rigtige tal, og dét at det starter med 10 fortæller hvilken given afdeling der er tale om, så ja alt skal med...

Blackadder - Den kører fint, men der sker ikke rigtigt noget. Forudsætter det at filen, og/eller arkene hedder noget bestemt ?

superjap - Jeg får "Subscipt out of range" på din.

Sub test()
Dim rng As Range
Dim rng2 As Range
Dim c As Range
Const filter = "10"
Set rng = Range("A:A")
Set rng2 = Range("A1:K1")
For Each c In rng
  If c.Value = "" Then Exit For 'spinger ud af løkke ved tom celle
  If Left(c, Len(filter)) = filter Then Set rng2 = Union(Range(c, c.Offset(0, 10)), rng2)
Next
rng2.Select
rng2.Copy
Workbooks.Add
ActiveSheet.Paste
ActiveWorkbook.SaveAs "c:\Amomobil.xls"
End Sub

Bak - dit geni - lægger du lige et svar ?

ok ...... :-)
Hvis du ikke ønsker at rækkerne skal mære markerede bagefter fjerner du linien:
rng2.Select

Tusind tak for hjælpen alle 3. Baks var en perfekt first-timer, så han får de fleste points. Men alletiders at I ville hjælpe...