Autokopier rækker til et andet ark - Excel.

Du skal bare bruge funktionen \'hvis\'

Eksempel:
=HVIS(Ark1!A1>2;SAND;FALSK)

Håber det virker...

Venligst
Thue

Hej Rodding

Det kunne være noget lignende dette :

Sub CopyValues()
Dim rCell As Range
Dim sValue As String
Dim rCell2 As Range

    sValue = \"VærdiJegSkalFinde\"
    For Each rCell In Worksheets(\"Ark1\").Range(\"A1:A30\")
        If rCell.Value = sValue Then
            rCell.EntireRow.Copy
            For Each rCell2 In Worksheets(\"Ark2\").Range(\"A1:A10000\")
                If rCell2.Value = \"\" Then
                    rCell2.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
                        False, Transpose:=False
                    Exit For
                End If
            Next rCell2
        End If
    Next rCell
End Sub

Hej Thue.

Jeg ved ikke rigtigt - eller også er det ikke sevet ind.

Hvis jeg har et område på ark1 fra A5..H175, hvor jeg ønsker at alle rækker, hvor kolonne
H indeholder ex. navnet \"Fidelia\", skal kopieres til Ark2. Hvis der findes 5 rækker med
\"Fidelia\" spredt på Ark1 skal disse gerne blive placeret i Ark2 fra ex. pos. A3 og 5 rækker
ned.

Her løbes igennem
Her løbes der igennem kolonne H for \"Fidelia\" og hele rækken kopieres, hvorefter det løbes nedad i ark2 efter første ledige celle som er blank. Godt
Nu smutter den tilbage til ark1, for at finde næste celle med \"Fidelia\" osv.

Sub CopyValues()
Dim rCell As Range
Dim sValue As String
Dim rCell2 As Range

    sValue = \"Fidelia\"

    For Each rCell In Worksheets(\"Ark1\").Range(\"H5:H175\")
        If rCell.Value = sValue Then
            rCell.EntireRow.Copy
            For Each rCell2 In Worksheets(\"Ark2\").Range(\"A1:A10000\")
                If rCell2.Value = \"\" Then
                    rCell2.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
                        False, Transpose:=False
                    Exit For
                End If
            Next rCell2
        End If
    Next rCell
End Sub

Hej Flemming.

Det ser ud til at du løber med point\'erne.

Jeg er på vej ud af døren så jeg vender tilbage.

I menuen Data er der et punkt der hedder Filter/Avanceret filter

Hvorfor ikke bruge denne funktion??

eller data / sorter - men det er jo ikke pr. automatik, men hårdt manuelt arbejde.

Mer vil ha\' mer.

Flemming, din kode er ok, men før du scorer point, så lige et tillægsspørgsmål.

Hvis jeg nu ved at Kolonne H indeholder max 10 forskellige værdier(navne) og at de alle skal kopieres til eget ark. Ja så ville det jo være smart hvis koden selv finder de forskellige væredier, opretter div. ark (opkaldt efter værdien), samt udfører kopieringen.

Ja ja, det er jo bare hvis...

nå så det vil mer !

Så prøv denne her - du skal dog helt manuelt oprette de max 10 forskellige ark, som skal benyttes, og give dem det HELT rigtige navn, for at makro\'en virker

Sub CopyValuesToSheets()
Dim rCell As Range
Dim sValue As String
Dim rCell2 As Range
    For Each rCell In Worksheets(\"Ark1\").Range(\"A1:A30\")
        sValue = rCell.Value
        rCell.EntireRow.Copy
        For Each rCell2 In Worksheets(sValue).Range(\"A1:A10000\")
            If rCell2.Value = \"\" Then
                rCell2.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
                    False, Transpose:=False
                Exit For
            End If
        Next rCell2
    Next rCell
End Sub

Hov... du skal dog selv lige ændre
For Each rCell In Worksheets(\"Ark1\").Range(\"A1:A30\")
til:
For Each rCell In Worksheets(\"Ark1\").Range(\"H5:H175\")

Mvh
Flemming

Den her kode virker lidt bedre - og så opretter og navngiver den automatisk nye ark.

God fornøjelse

Sub CopyValuesToSheets()
Dim rCell As Range
Dim sValue As String
Dim rCell2 As Range
    Application.ScreenUpdating = False
    For Each rCell In Worksheets(\"Ark1\").Range(\"H5:H175\")
        If rCell.Value = \"\" Then Exit For
        sValue = rCell.Value
        If SheetExists(sValue) = False Then
            Worksheets.Add.Move after:=Worksheets(Worksheets.Count)
            Worksheets(Worksheets.Count).Name = sValue
        End If
        rCell.EntireRow.Copy
        For Each rCell2 In Worksheets(sValue).Range(\"A1:A10000\")
            If rCell2.Value = \"\" Then
                rCell2.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
                    False, Transpose:=False
                Exit For
            End If
        Next rCell2
    Next rCell
    Application.CutCopyMode = False
End Sub

Public Function SheetExists(SheetName As String) As Boolean
    On Error Resume Next
    SheetExists = ActiveWorkbook.Worksheets(SheetName).Index
End Function

Nu tror jeg at det kommer til at virke.
Mange tak.

Velbekomme