23. december 2005 - 20:58Der er
15 kommentarer og 1 løsning
hjælp til macro
Hej.
Har en lille udfordring jeg har knoklet lidt med, men kan godt se at jeg skal bruge lidt eksperthjælp.
Jeg har et regneark med ca. 35.000 rækker. Hver måned kommer der en ny liste med nye rækker. Antallet svinger fra måned til måned. Men vil oftes ligge mellem 30.000 og 40.000.
Hver række består af følgende kolonner: Land Team No Navn Ono Farve Type Date Svc Svc d
Ono er et Ordrenummer. Det er ikke unikt, da der kan være flere vare på samme ordre. Desværre kan disse være spredt rundt i arket.
Der skal sorteres og fjernes i arket. Da der kommer et nyt ark tænkte jeg det ville være smart med en makro. Enten en som selv hentede data over eller hvor man manuelt kopierede data over. Jeg skal bruge en makro der skal kunne følgende:
Først skal der fjernes alle rækker som indholder farverne roed & blaa.
Så skal der ryddes op udfra følgende kriterier
Alle ordrenumre hvor en af varerne indeholder en af følgende kombination på felterne svc & svc d
BPack 3y NBDS 3y SVB 30D SPack 3Y
For eksempel. Hvis man søger på NBDS 3Y finder man følgende: Norway NW Websales 2199878 1 601325842 sort bil 17 26-10-2005 NBDS 3Y
Søger man videre på ordrenumret så kommer følgende 2 op:
Norway NW Websales 2199878 1 601325842 sort bil 17 26-10-2005
Til sidst skal der kun være de ordre tilbage hvor ingen af varerne indeholder ovenstående kombination. Derefter skal antallet beskæres så der kun er en vare tilbage for hvert ordernummer.
For eksempel. Så findes der på denne order 2 forskellige varer.
Sweden SW Websales 2279174 1 592490141 gul bil 3 26-10-2005
Sweden SW Websales 2279174 1 592490141 gul bil 3 26-10-2005 OTH 0Y
Dette skal skæres ned så der kun er en tilbage.
Sweden SW Websales 2279174 1 592490141 gul bil 3 26-10-2005
I ovenstående tlifælde står der samme tekst, men det kan sagtens være 2 forskellige tekster, dog vil følgende felster altid være ens: Land Team No Navn Ono Date
Slutteligt skal der sorteres på No. Her kan der godt være flere forskellige ordre (Ono) på samme nummer.
Kort sagt så skal hver ordre (Ono) hvor en af varerne ikke indeholder en af kombinationer (BPack+3y, NBDS+3y, SVB+30D eller SPack+3Y). Være repræsenteret med 1 linie.
På sheet1 er selve arket På sheet2 er et eksempel på hvordan resultatet kunne se ud. Dette er lavet på den langtrukne måde, så det er kun de ca. 500 som er rigige. :)
Med kunstig intelligens skaber HP’s nye OmniBook X 14 en unik og skræddersyet brugeroplevelse målrettet dem, der ønsker høj ydeevne og intelligente funktioner
først sætter den farver på de uønskede, og derefter kopierer resten over i Sheet3
Public Sub FarvUønskedeOgKopierResten() Dim FJ1 As Variant, Farve As Variant, RW As Long, I As Long, A As Long, X As Long, Data As Variant Farve = Array("roed", "blaa") FJ1 = Array("BPack3y", "NBDS3y", "SVB30D", "SPack3Y") RW = Range("A65536").End(xlUp).Row 'Land Team No Navn Ono Farve Type Date Svc Svc d ' 1 2 3 4 5 6 7 8 9 10
' laver tal som tekst om til tal Range("L1").Value = 1 Range("L1").Copy Range("C2:C" & RW & ",E2:E" & RW).Select Range("E1").Activate Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlMultiply, _ SkipBlanks:=False, Transpose:=False Range("L1") = ""
' sortering på Ono Columns("A:J").Sort Key1:=Range("E2"), Order1:=xlAscending, Header:= _ xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ DataOption1:=xlSortNormal
' finder de 2 farver Data = Range("A2:J" & RW) For I = 1 To UBound(Data) If Data(I, 6) = Farve(0) Or Data(I, 6) = Farve(1) Then Rows(I + 1).Interior.ColorIndex = 6 End If Next
'Finder Alle ordrenumre hvor en af varerne indeholder en af følgende kombination på felterne svc & svc d For I = 1 To UBound(Data) kb = Data(I, 9) & Data(I, 10) For A = 0 To 3 If FJ1(A) = kb Then For X = I - 10 To I + 10 If Data(X, 5) = Data(I, 5) Then Rows(X + 1).Interior.ColorIndex = 7 End If Next End If Next Next
' Farver dubletter For I = 2 To UBound(Data) If Data(I, 5) = Data(I - 1, 5) Then Rows(I + 1).Interior.ColorIndex = 8 End If Next ' Kopierer resten til Sheet3 For I = 1 To UBound(Data) If Rows(I & ":" & I).Interior.ColorIndex = xlNone Then Rows(I & ":" & I).Copy Sheets("Sheet3").Range("A" & Sheets("Sheet3").Range("A65536").End(xlUp).Row + 1) End If Next End Sub
kan vist koges ned til Public Sub FarvUønskedeOgKopierResten() Dim FJ1 As Variant, Farve As Variant, RW As Long, I As Long, A As Long, X As Long, Data As Variant Farve = Array("roed", "blaa") FJ1 = Array("BPack3y", "NBDS3y", "SVB30D", "SPack3Y") RW = Range("A65536").End(xlUp).Row 'Land Team No Navn Ono Farve Type Date Svc Svc d ' 1 2 3 4 5 6 7 8 9 10
' sortering på Ono Columns("A:J").Sort Key1:=Range("E2"), Order1:=xlAscending, Header:= _ xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ DataOption1:=xlSortNormal
' finder de 2 farver Data = Range("A2:J" & RW) For I = 1 To UBound(Data) If Data(I, 6) = Farve(0) Or Data(I, 6) = Farve(1) Then Rows(I + 1).Interior.ColorIndex = 6 End If Next
'Finder Alle ordrenumre hvor en af varerne indeholder en af følgende kombination på felterne svc & svc d For I = 1 To UBound(Data) kb = Data(I, 9) & Data(I, 10) For A = 0 To 3 If FJ1(A) = kb Then If I - 10 < 1 Then X = 1 Else X = I - 10 For X = X To I + 10 If Data(X, 5) = Data(I, 5) Then Rows(X + 1).Interior.ColorIndex = 7 End If Next End If Next Next
' Farver dubletter For I = 2 To UBound(Data) If Data(I, 5) = Data(I - 1, 5) Then Rows(I + 1).Interior.ColorIndex = 8 End If Next ' Kopierer resten til Sheet3 For I = 1 To UBound(Data) If Rows(I & ":" & I).Interior.ColorIndex = xlNone Then Rows(I & ":" & I).Copy Sheets("Sheet3").Range("A" & Sheets("Sheet3").Range("A65536").End(xlUp).Row + 1) End If Next End Sub
Public Sub FjernUønskedeOgKopierResten() Dim FJ1 As Variant, Farve As Variant, RW As Long, I As Long, A As Long, X As Long, Data As Variant, Tjek() As Variant Dim Res() As Variant, R As Long Farve = Array("roed", "blaa") FJ1 = Array("BPack3y", "NBDS3y", "SVB30D", "SPack3Y") RW = Sheets("Sheet1").Range("A65536").End(xlUp).Row ReDim Tjek(RW) 'Land Team No Navn Ono Farve Type Date Svc Svc d ' 1 2 3 4 5 6 7 8 9 10
' sortering på Ono Columns("A:J").Sort Key1:=Range("E2"), Order1:=xlAscending, Header:= _ xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ DataOption1:=xlSortNormal
' finder de 2 farver Data = Sheets("Sheet1").Range("A1:J" & RW) ReDim Res(UBound(Data), 9) For I = 1 To UBound(Data) If Data(I, 6) = Farve(0) Or Data(I, 6) = Farve(1) Then Tjek(I) = I End If Next
'Finder Alle ordrenumre hvor en af varerne indeholder en af følgende kombination på felterne svc & svc d For I = 1 To UBound(Data) kb = Data(I, 9) & Data(I, 10) For A = 0 To 3 If FJ1(A) = kb Then If I - 10 < 1 Then X = 1 Else X = I - 10 For X = X To I + 10 If Data(X, 5) = Data(I, 5) Then Tjek(I) = I End If Next End If Next Next
' Finder dubletter For I = 2 To UBound(Data) If Data(I, 5) = Data(I - 1, 5) Then Tjek(I) = I End If Next
' Overfører den der skal bruges til array res R = 0 For I = 1 To UBound(Tjek) If IsEmpty(Tjek(I)) Then For X = 1 To 10 Res(R, X - 1) = Data(I, X) Next
R = R + 1 End If Next ' Kopierer resten til Sheet3
Sheets("Sheet3").Range("A1").Resize(UBound(Res, 1), UBound(Res, 2)) = Res
Så kan den nok ikke blive hurtige. Den er en smule hurtigere end min egen version (det er jeg jo ikke meget for at indrømme) :-) Rigtig flot optimeret, kabbak Men jeg får faktisk to forskellige resultater, når jeg kører din første og din nye makro.
Nu er de tjekket op mod hinanden, der var lidt rettelser, men nu skulle de gøre det ens.
Public Sub FarvUønskedeOgKopierResten() Dim FJ1 As Variant, Farve As Variant, RW As Long, I As Long, A As Long, X As Long, Data As Variant Farve = Array("roed", "blaa") FJ1 = Array("BPack3y", "NBDS3y", "SVB30D", "SPack3Y") RW = Range("A65536").End(xlUp).Row 'Land Team No Navn Ono Farve Type Date Svc Svc d ' 1 2 3 4 5 6 7 8 9 10
' sortering på Ono Columns("A:J").Sort Key1:=Range("E2"), Order1:=xlAscending, Header:= _ xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ DataOption1:=xlSortNormal
' finder de 2 farver Data = Range("A1:J" & RW) For I = 1 To UBound(Data) If Data(I, 6) = Farve(0) Or Data(I, 6) = Farve(1) Then Rows(I).Interior.ColorIndex = 6 End If Next
'Finder Alle ordrenumre hvor en af varerne indeholder en af følgende kombination på felterne svc & svc d For I = 1 To UBound(Data) kb = Data(I, 9) & Data(I, 10) For A = 0 To 3 If FJ1(A) = kb Then If I - 10 < 1 Then X = 1 Else X = I - 10 For X = X To I + 10 If Data(X, 5) = Data(I, 5) Then Rows(X).Interior.ColorIndex = 7 End If Next End If Next Next
' Farver dubletter For I = 2 To UBound(Data) If Data(I, 5) = Data(I - 1, 5) And Rows(I).Interior.ColorIndex = xlNone And Rows(I - 1).Interior.ColorIndex = xlNone Then Rows(I - 1).Interior.ColorIndex = 8 End If Next ' Kopierer resten til Sheet4 R = 1 For I = 1 To UBound(Data) If Rows(I & ":" & I).Interior.ColorIndex = xlNone Then Rows(I & ":" & I).Copy Sheets("Sheet4").Range("A" & R) R = R + 1 End If Next End Sub
Public Sub FjernUønskedeOgKopierResten() Dim FJ1 As Variant, Farve As Variant, RW As Long, I As Long, A As Long, X As Long, Data As Variant, Tjek() As Variant Dim Res() As Variant, R As Long Farve = Array("roed", "blaa") FJ1 = Array("BPack3y", "NBDS3y", "SVB30D", "SPack3Y") RW = Sheets("Sheet1").Range("A65536").End(xlUp).Row ReDim Tjek(RW) 'Land Team No Navn Ono Farve Type Date Svc Svc d ' 1 2 3 4 5 6 7 8 9 10
' sortering på Ono Columns("A:J").Sort Key1:=Range("E2"), Order1:=xlAscending, Header:= _ xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ DataOption1:=xlSortNormal
' finder de 2 farver Data = Sheets("Sheet1").Range("A1:J" & RW) ReDim Res(UBound(Data), 9) For I = 1 To UBound(Data) If Data(I, 6) = Farve(0) Or Data(I, 6) = Farve(1) Then Tjek(I) = I End If Next
'Finder Alle ordrenumre hvor en af varerne indeholder en af følgende kombination på felterne svc & svc d For I = 1 To UBound(Data) kb = Data(I, 9) & Data(I, 10) For A = 0 To 3 If FJ1(A) = kb Then If I - 10 < 1 Then X = 1 Else X = I - 10 For X = X To I + 10 If Data(X, 5) = Data(I, 5) Then Tjek(X) = I End If Next End If Next Next
' Finder dubletter For I = 2 To UBound(Data) If Data(I, 5) = Data(I - 1, 5) And IsEmpty(Tjek(I)) And IsEmpty(Tjek(I - 1)) Then Tjek(I - 1) = I End If Next
' Overfører den der skal bruges til array res R = 0 For I = 1 To UBound(Tjek) If IsEmpty(Tjek(I)) Then For X = 1 To 10 Res(R, X - 1) = Data(I, X) Next
R = R + 1 End If Next ' Kopierer resten til Sheet3
Sheets("Sheet3").Range("A1").Resize(UBound(Res, 1), (UBound(Res, 2) + 1)) = Res
Wow. Dette er vildt. Havde håbet der var kommet svar, når jeg kom fra juleferie, men havde ikke regnet med at der 4 timer senere ville være et super svar. Jeg takker mange gange for hjælpe.
Et godt nytår til jer begge og tak for hjælpen.
/fanth
ps. er ikke den store bruger herinde, så er der ikke en som kan fortælle hvordan jeg giver de fortjente point til kabbak?
Public Sub FjernUønskedeOgKopierResten() Dim FJ1 As Variant, Farve As Variant, RW As Long, I As Long, A As Long, X As Long, Data As Variant, Tjek() As Variant Dim Res() As Variant, R As Long tid = Now() Farve = Array("roed", "blaa") FJ1 = Array("BPack3y", "NBDS3y", "SVB30D", "SPack3Y") RW = Sheets("Sheet1").Range("A65536").End(xlUp).Row ReDim Tjek(RW) 'Land Team No Navn Ono Farve Type Date Svc Svc d ' 1 2 3 4 5 6 7 8 9 10
' sortering på Ono Columns("A:J").Sort Key1:=Range("E2"), Order1:=xlAscending, Header:= _ xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ DataOption1:=xlSortNormal
' finder de 2 farver Data = Sheets("Sheet1").Range("A1:J" & RW) ReDim Res(UBound(Data), 9) For I = 1 To UBound(Data) If Data(I, 6) = Farve(0) Or Data(I, 6) = Farve(1) Then Tjek(I) = I End If Next
'Finder Alle ordrenumre hvor en af varerne indeholder en af følgende kombination på felterne svc & svc d For I = 1 To UBound(Data) kb = Data(I, 9) & Data(I, 10) For A = 0 To 3 If FJ1(A) = kb Then If I - 10 < 1 Then X = 1 Else X = I - 10 For X = X To I + 10 If Data(X, 5) = Data(I, 5) Then Tjek(X) = I End If Next End If Next Next
' Finder dubletter For I = 2 To UBound(Data) If Data(I, 5) = Data(I - 1, 5) And IsEmpty(Tjek(I)) And IsEmpty(Tjek(I - 1)) Then Tjek(I - 1) = I End If Next
' Overfører den der skal bruges til array res R = 0 For I = 1 To UBound(Tjek) If IsEmpty(Tjek(I)) Then For X = 1 To 10 Res(R, X - 1) = Data(I, X) Next
R = R + 1 End If Next ' Kopierer resten til Sheet3
Sheets("Sheet3").Range("A1").Resize(UBound(Res, 1), (UBound(Res, 2) + 1)) = Res
' sortering på no Sheets("Sheet3").Select Columns("A:J").Sort Key1:=Range("C2"), Order1:=xlAscending, Header:= _ xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ DataOption1:=xlSortNormal ' tidtagning MsgBox " det tog " & Format((Now() - tid), "nn:ss") & " minutter" & vbCrLf _ & "For " & I & " datalinier", vbOKOnly, "Tidtagning" End Sub
Synes godt om
Ny brugerNybegynder
Din løsning...
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.
