Kopier rækker fra et array til et andet array hvis kriterier er opfyldt.

Et par små ændringer og det buede virke :

Public Sub KopierFraArray()
    Dim MyArray As Variant
    Dim NewArray As Variant
    Dim x As Integer
    Dim Y As Integer
    Dim k As Integer

    k = 1
    'Range indlæses i MyArray - antal rækker kan variere fra 50 - 300. Antal kolonner vil stort set være det samme hver gang.
    MyArray = Ark1.Range("AT151", Ark1.Range("AT151").End(xlDown).End(xlToRight))
    'det nye array skal dimmmes
    ReDim NewArray(1 To UBound(MyArray, 1), 1 To UBound(MyArray, 2))
    For x = LBound(MyArray, 1) To UBound(MyArray, 1)


        'Hvis en række har følgende værdier i 3 kolonner:
        'Værdien i kolonne 3 (i MyArray) er "Visa/dk", værdien i kolonne 4 er dato "23-06-14"
        'og værdien i kolonne 5 er "1234"
        'Så skal rækken kopieres til NewArray.

        If MyArray(x, 3) = "Visa/dk" And MyArray(x, 4) = "23-06-14" And MyArray(x, 5) = "1234" Then
            For Y = LBound(MyArray, 2) To UBound(MyArray, 2)
                NewArray(k, Y) = MyArray(x, Y)
            Next
            k = k + 1
        End If

    Next

    Ark2.Range("V35").Resize(UBound(NewArray, 1), UBound(NewArray, 2)) = NewArray
    Set NewArray = Nothing

End Sub

Ups, havde lige brugt egne arknavne

Public Sub KopierFraArray()
    Dim MyArray As Variant
    Dim NewArray As Variant
    Dim x As Integer
    Dim Y As Integer
    Dim k As Integer

    k = 1
    'Range indlæses i MyArray - antal rækker kan variere fra 50 - 300. Antal kolonner vil stort set være det samme hver gang.
    MyArray = Ark1.Range("AT151", Range("AT151").End(xlDown).End(xlToRight))
    'det nye array skal dimmmes
    ReDim NewArray(1 To UBound(MyArray, 1), 1 To UBound(MyArray, 2))
    For x = LBound(MyArray, 1) To UBound(MyArray, 1)


        'Hvis en række har følgende værdier i 3 kolonner:
        'Værdien i kolonne 3 (i MyArray) er "Visa/dk", værdien i kolonne 4 er dato "23-06-14"
        'og værdien i kolonne 5 er "1234"
        'Så skal rækken kopieres til NewArray.

        If MyArray(x, 3) = "Visa/dk" And MyArray(x, 4) = "23-06-14" And MyArray(x, 5) = "1234" Then
            For Y = LBound(MyArray, 2) To UBound(MyArray, 2)
                NewArray(k, Y) = MyArray(x, Y)
            Next
            k = k + 1
        End If

    Next

    Range("V35").Resize(UBound(NewArray, 1), UBound(NewArray, 2)) = NewArray
    Set NewArray = Nothing

End Sub

Hej Bak

Mange tak for dit svar.
Det fungerer helt efter hensigten:)

Men jeg har et lille problem mere, som jeg håber du kan hjælpe med.

Der skal sorteres efter et kriterium mere.
I en kolonne (5), skal der også sortere efter klokkeslæt, i start og slut af ugen.
Jeg har skrevet det ind i koden, men det fungerer ikke som det skal.

Det ser ud til, at der er problemer når klokkeslættet starter med "00" eller "01".
Er det måske et klokkeslæt-format der skal skrives ind i koden ?
Har du et bud på hvad der er galt ?

Bemærk ændringer i koden:
Range er ændret til "Range("AT15")
I MyArray er kolonne 5 nu "klokkeslæt" og kolonne 7 er "1234".



Public Sub KopierFraArray1()
    Dim MyArray As Variant
    Dim NewArray As Variant
    Dim x As Integer
    Dim Y As Integer
    Dim k As Integer

    k = 1
    'Range indlæses i MyArray - antal rækker kan variere fra 50 - 300. Antal kolonner vil stort set være det samme hver gang.
    MyArray = Ark1.Range("AT15", Range("AT15").End(xlDown).End(xlToRight))
    'det nye array skal dimmmes
    ReDim NewArray(1 To UBound(MyArray, 1), 1 To UBound(MyArray, 2))
    For x = LBound(MyArray, 1) To UBound(MyArray, 1)


        'Hvis en række har følgende værdier i 3 kolonner:
        'Værdien i kolonne 3 (i MyArray) er "Visa/dk", værdien i kolonne 4 er dato "23-06-14"
        'og værdien i kolonne 5 er "1234"
        'Så skal rækken kopieres til NewArray.

        If MyArray(x, 3) = "Visa/dk" And MyArray(x, 4) = "21-06-2014" And MyArray(x, 5) < "14:00:00" And MyArray(x, 7) = "1234" Then
            For Y = LBound(MyArray, 2) To UBound(MyArray, 2)
                NewArray(k, Y) = MyArray(x, Y)
            Next
            k = k + 1
        End If

    Next

    Range("V35").Resize(UBound(NewArray, 1), UBound(NewArray, 2)) = NewArray
    Set NewArray = Nothing

End Sub

Hej bak

Det fungerer helt efter hensigten med den lille ændring i arrayet.
Og jeg har fundet ud af at indsætte kriterier for klokkeslæt og dato i array.

Sender du et svar? - så jeg kan give dig points :)

Laugesen

Her er så lige et svar :-)

Mange tak for hjælpen :)

Laugesen