15. juli 2014 - 00:33Der er
5 kommentarer og 1 løsning
Kopier rækker fra et array til et andet array hvis kriterier er opfyldt.
Jeg skal hver uge fortage en sortering af data fra et ark som kan variere i størrelse på 50 -300 rækker. Rækker der opfylder kriterier i 3 kolonner, skal kopieres til et andet område eller til et andet ark.
For at forøge hastigheden af processen, har jeg indlæst alle data i et array (MyArray), og har prøvet at lave en makro der skal kopiere de enkelte rækker fra arrayet - hvis kriterierne er opfyldt - og sætte dem ind i et nyt array(NewArray). Sortering skal ske efter 3 kriterier i kolonnerne 3 - 4 - 5 i det indlæste array(MyArray).
Rækkerne der bliver kopieret over i det nye array, skal til sidst kopieres tilbage til arket.
Men jeg kan ikke få det til at fungere ! Er der nogen der kan give et bud på hvad der er galt med koden ?
På Forhånd tak.
Laugesen
Koden:
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 = Range("AT15", Range("AT15").End(xlDown).End(xlToRight))
For x = LBound(MyArray, 1) To UBound(MyArray, 1) For Y = LBound(MyArray, 2) To UBound(MyArray, 2)
'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 NewArray(k, Y) = MyArray(x, Y) k = 1 + 1 End If Next Next
Range("V35").Resize(UBound(NewArray, 1), UBound(NewArray, 2)) = NewArray Set NewArray = Nothing
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
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
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
Tilladte BB-code-tags: [b]fed[/b] [i]kursiv[/i] [u]understreget[/u] Web- og emailadresser omdannes automatisk til links. Der sættes "nofollow" på alle links.