VBA excel Adatok összerendezése gyorsabban
2020-06-17T09:47:10+02:00
2020-08-06T11:44:19+02:00
2022-08-11T21:15:32+02:00
AKA
Van két táblázatom, egyikben: ID, Hely, Állapot, típus; tartó, time stamp oszlopok

Másikban ID, és verzió oszlopok. A táblázatok több ezer sort tartalmaznak.

Ezek az adatok nem aktuálisak hanem egy visszakövetési rendszerből származnak. Ez azt jeleni, hogy a termék életútjának összes változását tartalmazza, az adott időintervallumon belül. Tehát az első táblázat többször tartalmazza az ID-t különböző adatokkal. A második táblázatban az ID egyedi.  A két táblázatban az ID ugyanaz, de lehet olyan, hogy az ID csak az egyik táblában van, másikban nincs.

Cél az, hogy olyan táblázatot készítsek ahol az ID egyedi mellette verzió és hely szerint külön oszlopokban csoportosítva a tartók és a típus, valamint időpont szerint a legutolsó hely külön csoportosítva. 3 hely lehetséges.

ID, verzió,  (tartó, típus) 1. hely , (tartó, típus) 2.hely , (tartó, típus) 3. hely,  aktuális tartó, aktuális tartó típus, time stamp

Ez a feladat megcsináltam (VBA) ciklusban, de nagyon lassú, több mint egy óra még lefut. (12e sor) (W10_64bit + excel 32bit)

A ciklus az első táblában fut le minden soron. A ciklusba van beágyazva a Application.Match(ID, DATA_RNG, 0) ami a második táblában megtalálja a cél sort. Majd a logika szerint átmásolja az adatokat a megfelelő oszlopokba.

Hogyan lehet ezt sokkal gyorsabban megoldani?
Mutasd a teljes hozzászólást!
Szia!
Közben egy kicsit átírtam a korábbi makrómat. A lényeg, hogy a keresést nem a munkalapon, hanem a memóriában végzi, ami elvileg nagyságrendekkel gyorsabb.

Sub QLOT_data_chk_and_save_uj() Dim LOT_RNG() Dim DATA_RNG() Dim SOR_LOT As Variant, sSor As Long Dim SOR_DATA As Variant Dim LOT, Reference, STATUS, Machine, Scrap_Desc, ScrapID Dim LOT1, LOT2, LOT3, Verzio Dim LOT_DATE As Date Dim LAST_LOT_DATE As Date Dim HELY As String Dim SHFORR As Worksheet, SHCEL As Worksheet Dim asor As Long, bsor As Range On Error Resume Next Application.ScreenUpdating = False asor = Worksheets("Q_DATA_assy").Cells(Rows.Count, 1).End(xlUp) + 1 bsor = Worksheets("SCRs").Cells(Rows.Count, 1).End(xlUp) + 1 Set SHCEL = Worksheets("Q_DATA") SHCEL.Activate DATA_RNG = Application.Transpose(SHCEL.Range(Range("A4"), Range("A4").End(xlDown)).Value) Set SHFORR = Worksheets("Q_LOTS") SHFORR.Activate LOT_RNG = Application.Transpose(SHFORR.Range(Range("A3"), Range("A3").End(xlDown)).Value) For sSor = 1 To UBound(LOT_RNG) Err = 0 With SHFORR SOR_DATA = Application.Match(LOT_RNG(sSor), DATA_RNG, 0) + 3 If Not IsError(SOR_DATA) Then 'Err = 0 Then STATUS = .Range("D" & sSor + 2) Scrap_Desc = .Range("F" & sSor + 2) ScrapID = .Range("E" & sSor + 2) LOT = .Range("M" & sSor + 2) Reference = .Range("I" & sSor + 2) LOT_DATE = .Range("O" & sSor + 2) HELY = Left(.Range("C" & sSor + 2), 5) Verzio = .Range("K" & sSor + 2) LAST_LOT_DATE = SHCEL.Range("H" & SOR_DATA) If LAST_LOT_DATE <> .Range("N" & SOR_DATA) And Reference = .Range("L" & SOR_DATA) Then With SHCEL If .Range(Application.Choose(Application.Match(HELY, Array("FT_BM", "FT_WE", "FT_AS"), 0), "D", "G", "J") & SOR_DATA) = "" Then .Range(Application.Choose(Application.Match(HELY, Array("FT_BM", "FT_WE", "FT_AS"), 0), "D", "G", "J") & SOR_DATA) = LOT .Range(Application.Choose(Application.Match(HELY, Array("FT_BM", "FT_WE", "FT_AS"), 0), "E", "H", "K") & SOR_DATA) = Reference .Range(Application.Choose(Application.Match(HELY, Array("FT_BM", "FT_WE", "FT_AS"), 0), "F", "I", "M") & SOR_DATA) = LOT_DATE If HELY = "FT_AS" Then .Range("L" & SOR_DATA) = Verzio End If .Range("N" & SOR_DATA) = LOT .Range("O" & SOR_DATA) = Reference .Range("P" & SOR_DATA) = LOT_DATE If STATUS = "Active" And HELY = "FT_AS" Then .Range("A" & SOR_DATA & ":U" & SOR_DATA).Copy Destination:=Worksheets("Q_DATA_assy").Cells("A" & asor) asor = asor + 1 .Cells(SOR_DATA, "AX").Value = "X" End If If STATUS = "Scrapped" Then .Range("Q" & SOR_DATA) = STATUS .Range("R" & SOR_DATA) = ScrapID .Range("S" & SOR_DATA) = Scrap_Desc .Range("A" & SOR_DATA & ":U" & SOR_DATA).Copy Destination:=Worksheets("SCRs").Cells("A" & bsor) .Cells(SOR_DATA, "AX").Value = "X" End If End With End If End If End With LOT = "" Reference = "" LOT_DATE = "" Machine = "" Verzio = "" STATUS = "" Next Application.ScreenUpdating = True End Sub
Érdekelne, hogy így gyorsult-e valamivel.
Üdv.
Mutasd a teljes hozzászólást!

  • Szia!

    Szerintem érdemes lenne a függvény helyett a Range.Find metódust használni.
    Továbbá, mivel nem mutattad a makrót, akkor érdemes még kikapcsolni a képernyő frissítést 
    Application.ScreenUpdating  (=False az elején és True a végén)
    Aztán kigyomlálni az összes Select és Activate utasítást belőle.
    A másolásnál a Copy parancsnak Destination paraméterrel meg lehet adni, hova másoljon.
    Hogyan érzékeled, ha a második táblában van olyan ID, ami nincs meg az elsőben?
    Ha a makrót is látnánk, akkor többet tudnánk segíteni. 

    Üdv.
    Mutasd a teljes hozzászólást!
  • Szia FFeri , köszi a választ.

    Annyi infó pluszban, hogy ha státusz "SCR" akkor a céltáblából áthelyezi a sort egy harmadik táblába. Ezt a funkciót leválasztva gyorsabb lesz ugyan a futás, de nem számottevően.

    Makró:

    Sub QLOT_data_chk_and_save() Dim LOT_RNG As Range Dim DATA_RNG As Range Dim SOR_LOT As Range Dim SOR_DATA As Variant Dim ID As String Dim LOT, Reference, STATUS, Machine, Scrap_Desc, ScrapID Dim LOT1, LOT2, LOT3, Variant Dim LOT_DATE As Date Dim LAST_LOT_DATE As Date On Error Resume Next Application.ScreenUpdating = False Worksheets("Q_DATA").Activate Set DATA_RNG = Worksheets("Q_DATA").Range(Range("A4"), Range("A4").End(xlDown)) Worksheets("Q_LOTS").Activate Set LOT_RNG = Worksheets("Q_LOTS").Range(Range("A3"), Range("A3").End(xlDown)) For Each SOR_LOT In LOT_RNG Err = 0 STATUS = Worksheets("Q_LOTS").Range("D" & SOR_LOT.Row) Scrap_Desc = Worksheets("Q_LOTS").Range("F" & SOR_LOT.Row) ScrapID = Worksheets("Q_LOTS").Range("E" & SOR_LOT.Row) ID = Worksheets("Q_LOTS").Range("A" & SOR_LOT.Row) LOT = Worksheets("Q_LOTS").Range("M" & SOR_LOT.Row) Reference = Worksheets("Q_LOTS").Range("I" & SOR_LOT.Row) LOT_DATE = Worksheets("Q_LOTS").Range("O" & SOR_LOT.Row) HELY = Left(Worksheets("Q_LOTS").Range("C" & SOR_LOT.Row), 5) Variant = Worksheets("Q_LOTS").Range("K" & SOR_LOT.Row) SOR_DATA = Application.Match(ID, DATA_RNG, 0) + 3 If Err = 0 Then ID_X = Worksheets("Q_DATA").Range("A" & SOR_DATA) LOT1 = Worksheets("Q_DATA").Range("D" & SOR_DATA) LOT2 = Worksheets("Q_DATA").Range("G" & SOR_DATA) LOT3 = Worksheets("Q_DATA").Range("J" & SOR_DATA) LAST_LOT_DATE = Worksheets("Q_DATA").Range("H" & SOR_DATA) If LAST_LOT_DATE = Worksheets("Q_LOTS").Range("N" & SOR_DATA) Or _ Reference = Worksheets("Q_LOTS").Range("L" & SOR_DATA) Then GoTo nextX ElseIf LOT1 = "" And HELY = "FT_BM" Then Worksheets("Q_DATA").Range("D" & SOR_DATA) = LOT Worksheets("Q_DATA").Range("E" & SOR_DATA) = Reference Worksheets("Q_DATA").Range("F" & SOR_DATA) = LOT_DATE GoTo tovabb ElseIf LOT2 = "" And HELY = "FT_WE" Then Worksheets("Q_DATA").Range("G" & SOR_DATA) = LOT Worksheets("Q_DATA").Range("H" & SOR_DATA) = Reference Worksheets("Q_DATA").Range("I" & SOR_DATA) = LOT_DATE GoTo tovabb ElseIf LOT3 = "" And HELY = "FT_AS" Then Worksheets("Q_DATA").Range("J" & SOR_DATA) = LOT Worksheets("Q_DATA").Range("K" & SOR_DATA) = Reference Worksheets("Q_DATA").Range("L" & SOR_DATA) = Variant Worksheets("Q_DATA").Range("M" & SOR_DATA) = LOT_DATE GoTo tovabb End If End If GoTo nextX tovabb: Worksheets("Q_DATA").Range("N" & SOR_DATA) = LOT Worksheets("Q_DATA").Range("O" & SOR_DATA) = Reference Worksheets("Q_DATA").Range("P" & SOR_DATA) = LOT_DATE If STATUS = "Active" And HELY = "FT_AS" Then Worksheets("Q_DATA").Rows(SOR_DATA & ":" & SOR_DATA).Cut Worksheets("Q_DATA_assy").Rows("4:4").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromRightOrBelow Worksheets("Q_DATA").Rows(SOR_DATA & ":" & SOR_DATA).Delete Shift:=xlUp Worksheets("Q_DATA").Activate Set DATA_RNG = Worksheets("Q_DATA").Range(Range("A4"), Range("A4").End(xlDown)) ElseIf STATUS = "Scrapped" Then Worksheets("Q_DATA").Range("Q" & SOR_DATA) = STATUS Worksheets("Q_DATA").Range("R" & SOR_DATA) = ScrapID Worksheets("Q_DATA").Range("S" & SOR_DATA) = Scrap_Desc Worksheets("Q_DATA").Rows(SOR_DATA & ":" & SOR_DATA).Cut Worksheets("SCRs").Rows("4:4").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromRightOrBelow Worksheets("Q_DATA").Rows(SOR_DATA & ":" & SOR_DATA).Delete Shift:=xlUp Worksheets("Q_DATA").Activate Set DATA_RNG = Worksheets("Q_DATA").Range(Range("A4"), Range("A4").End(xlDown)) End If nextX: LOT = "" Reference = "" LOT_DATE = "" Machine = "" Variant = "" STATUS = "" Next Application.ScreenUpdating = True End Sub
    Mutasd a teljes hozzászólást!
  • Szia!
    Nézd meg ezt a verziót, remélem, azt csinálja, amit az eredeti csak valamivel gyorsabban.
    Ha nem gyorsulna nagyon, akkor van még gondolatom, de az hosszabb időt igényel.

    Sub QLOT_data_chk_and_save_uj() Dim LOT_RNG As Range Dim DATA_RNG As Range Dim SOR_LOT As Range Dim SOR_DATA As Variant Dim ID As String, ID_X As String Dim LOT, Reference, STATUS, Machine, Scrap_Desc, ScrapID Dim LOT1, LOT2, LOT3, Verzio Dim LOT_DATE As Date Dim LAST_LOT_DATE As Date Dim HELY As String Dim SHFORR As Worksheet, SHCEL As Worksheet Dim asor As Long, bsor As Range On Error Resume Next Application.ScreenUpdating = False asor = Worksheets("Q_DATA_assy").Cells(Rows.Count, 1).End(xlUp) + 1 bsor = Worksheets("SCRs").Cells(Rows.Count, 1).End(xlUp) + 1 Set SHFORR = Worksheets("Q_LOTS") Set SHCEL = Worksheets("Q_DATA") '.Activate Set DATA_RNG = SHCEL.Range(Range("A4"), Range("A4").End(xlDown)) '.Activate Set LOT_RNG = SHFORR.Range(Range("A3"), Range("A3").End(xlDown)) For Each SOR_LOT In LOT_RNG.Cells Err = 0 With SHFORR ID = .Range("A" & SOR_LOT.Row) SOR_DATA = Application.Match(ID, DATA_RNG, 0) + 3 If Err = 0 Then STATUS = .Range("D" & SOR_LOT.Row) Scrap_Desc = .Range("F" & SOR_LOT.Row) ScrapID = .Range("E" & SOR_LOT.Row) LOT = .Range("M" & SOR_LOT.Row) Reference = .Range("I" & SOR_LOT.Row) LOT_DATE = .Range("O" & SOR_LOT.Row) HELY = Left(.Range("C" & SOR_LOT.Row), 5) Verzio = .Range("K" & SOR_LOT.Row) ID_X = SHCEL.Range("A" & SOR_DATA) LOT1 = SHCEL.Range("D" & SOR_DATA) LOT2 = SHCEL.Range("G" & SOR_DATA) LOT3 = SHCEL.Range("J" & SOR_DATA) LAST_LOT_DATE = SHCEL.Range("H" & SOR_DATA) If LAST_LOT_DATE <> .Range("N" & SOR_DATA) And Reference = .Range("L" & SOR_DATA) Then 'GoTo nextX Select Case HELY Case "FT_BM" If LOT1 = "" Then 'And HELY = "FT_BM" SHCEL.Range("D" & SOR_DATA) = LOT SHCEL.Range("E" & SOR_DATA) = Reference SHCEL.Range("F" & SOR_DATA) = LOT_DATE 'GoTo tovabb End If Case "FT_WE" If LOT2 = "" Then 'And HELY = "FT_WE" SHCEL.Range("G" & SOR_DATA) = LOT SHCEL.Range("H" & SOR_DATA) = Reference SHCEL.Range("I" & SOR_DATA) = LOT_DATE 'GoTo tovabb End If Case "FT_AS" If LOT3 = "" Then 'And HELY = "FT_AS" SHCEL.Range("J" & SOR_DATA) = LOT SHCEL.Range("K" & SOR_DATA) = Reference SHCEL.Range("L" & SOR_DATA) = Verzio SHCEL.Range("M" & SOR_DATA) = LOT_DATE 'GoTo tovabb End If End Select 'End If 'GoTo nextX 'tovabb: With SHCEL .Range("N" & SOR_DATA) = LOT .Range("O" & SOR_DATA) = Reference .Range("P" & SOR_DATA) = LOT_DATE If STATUS = "Active" And HELY = "FT_AS" Then .Range("A" & SOR_DATA & ":U" & SOR_DATA).Copy Destination:=Worksheets("Q_DATA_assy").Cells("A" & asor) asor = asor + 1 .Cells(SOR_DATA, "AX").Value = "X" 'Worksheets("Q_DATA_assy").Rows("4:4").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromRightOrBelow 'SHCEL.Rows(SOR_DATA & ":" & SOR_DATA).Delete Shift:=xlUp 'SHCEL.Activate 'Set DATA_RNG = SHCEL.Range(Range("A4"), Range("A4").End(xlDown)) End If If STATUS = "Scrapped" Then .Range("Q" & SOR_DATA) = STATUS .Range("R" & SOR_DATA) = ScrapID .Range("S" & SOR_DATA) = Scrap_Desc .Range("A" & SOR_DATA & ":U" & SOR_DATA).Copy Destination:=Worksheets("SCRs").Cells("A" & bsor) .Cells(SOR_DATA, "AX").Value = "X" '.Rows(SOR_DATA & ":" & SOR_DATA).Cut 'Worksheets("SCRs").Rows("4:4").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromRightOrBelow 'SHCEL.Rows(SOR_DATA & ":" & SOR_DATA).Delete Shift:=xlUp 'SHCEL.Activate 'Set DATA_RNG = SHCEL.Range(Range("A4"), Range("A4").End(xlDown)) End If End With End If End If End With 'nextX: LOT = "" Reference = "" LOT_DATE = "" Machine = "" Verzio = "" STATUS = "" Next Application.ScreenUpdating = True End Sub
    A törléseket nem hajtja végre, csak az AX oszlopban X-szel megjelöli a törlendő sorokat. Azokat utána egy szűréssel el lehet távolítani.
    Az Insert és a Delete (plusz Cut...) azért elég időigényes nagyobb állománynál. Gondold át, minden alkalommal meg kell mozgatni a hátralevő sorokat.
    Mivel sok adatról van szó, azért villámgéza nem játszik.


    Üdv.
    Mutasd a teljes hozzászólást!
  • Szia Fferi,

    kipróbáltam köszönöm működik. Jóval szebb a struktúra. Nálam a sok ugrálás már nem tetszett, de ez csak szükség megoldás volt a folyamat gyorsítására. Sajnos a te verziód is nagyon lassú. 46 perc volt, törlések nélkül. A függvénynél veszít sok időt.

    SOR_DATA = Application.Match(ID, DATA_RNG, 0) + 3

    helyette kipróbáltam ezt is, de ez is lassú:

    With DATA_RNG Set r = .Find(What:=barcode, After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, _ SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False) SOR_DATA = r.Row End With
    Mutasd a teljes hozzászólást!
  • Szia!
    A Find metódusnál a

    SearchOrder:=xlByRows helyett próbál meg xlByColumns paraméterrel. Bár elvileg ugye 1 oszlopod van.
    Szóba jöhet még előzetes rendezés, hogy ne mindig előlről kelljen keresni.

    Üdv.
    Mutasd a teljes hozzászólást!
  • Szia!

    Nem tudom mitől, de nekem pl a cellába írás iszonyatosan lassú. 2-3ezer sor átvizsgálása 1mp, mire beírja a cellába a találta datokat (6 oszlop, és általában 1-8 sor) az meg kb 15-25 mp.
    Szóval próbáld meg lefuttatni a nélkül, hogy beírj az adatoka, hogy úgy mennyi idő alatt végez.
    Ez az utolsó Office frissítés óta áll fent nálam.
    Mutasd a teljes hozzászólást!
  • Szia Pados, Ezt én is észrevettem, ezért már csak jelölöm, hogy mit szeretnék másolni aztán a ciklus végén egy lépésben átmásolom az adatokat. Sajnos az alap problémán ez sem segít,  a ciklusban a Find és a Match is lassú, hiába csoportosítom, sorrendbe rendezem az adatokat, nem lesz gyorsabb. Jelenleg 28 perc alatt fut le, ami még mindig nem elfogadható.
    Mutasd a teljes hozzászólást!
  • (Bocs, ha nyilvánvaló, de a rendezés nem önmagában gyorsít, hanem a keresésnél nem kell mindig az összes sorban keresni, hanem csak a már megtalált fölötti ID-kban.)
     
    Saját ötleteim: 
    1. Minden változó típusos deklarálása: pl. LOT3 long, persze ekkor az IF-be =0-ra kell vizsgálni.
     
    2. Különösen igaz a fenti a SOR_DATA és a SOR_LOT-ra.
     
    3. Illetve külön változó lehet a SOR_LOT.Row a For ciklus elején, így a hivatkozásokban a Range("oszlop",...) átalakítható cells(i,j) formátumúra.
     
    4. Az ID_X, ..., LAST_LOT_DATE 5 db értékadásnál használhatsz With SHCELL ... End with-et
     
    5. Vagy ha még jobban megnézzük: a ciklusban az SHFORR WS-re van jóval kevesebb hivatkozás mint az SHCEL-re, így talán érdemesebb volna a With SHCEL külső blokként, és belül a néhány SHFORR-ra a külön prefix.
     
    6. A ScreenUpdating-gel párhuzamosan:
    Application.Calculation = xlCalculationManual/xlCalculationAutomatic
    Application.EnableEvents=On/Off
    Mutasd a teljes hozzászólást!
  • Szia!
    A SOR_DATA azért Variant, mert az Application.Match eredménye lehet valódi találat és lehet hiba, így csak a Variant típus jöhet szóba.
    A SOR_LOT Range-ként van definiálva.
    LOT1,..stb. nem tudhatjuk előre, milyen típus - legalábbis a példa információi alapján nem.
    Az eseménykezelést nem kapcsolnám ki, sőt a ciklusba beletennék egy DoEvents-et, hogy megelőzzük a lefagyásveszélyt, ill. meg lehessen szakítani a futást.

    Üdv.
    Mutasd a teljes hozzászólást!
  • Szia!
    Az ID milyen felépítésű, megmutatnád?
    Üdv.
    Mutasd a teljes hozzászólást!
  • Igazad van, kissé felületes voltam.

    Cserébe még egy ötlet: Ha a több azonos ID-t tartalmazó sheet rendezett, akkor csak az 1. ID-t kell keresni az azonosakból a másik táblában. Így persze szükséges egy segédoszlop az 1-ben.
    Mutasd a teljes hozzászólást!
  • Szia Fferi,

    Bocs hogy eltűntem.. 18 karakteres szám az ID, (azaz egy bárkód)

    Átalakítottam az ötletek alapján a programot és találtam egy  hibát a ciklusban:

    Dim LOT_RNG As Range Dim SOR_LOT As Range ... For Each SOR_LOT In LOT_RNG
    Tehát megnéztem egy adott mérettel rendelkező Range-ben az össszes létező verzióban előforduló Range-t.. Ha ez igaz, akkor a 20perces futás nem is rossz eredmény tekintve hogy több ezer soros a LOT_RNG 

    köszi szépen a segítséget.
    Mutasd a teljes hozzászólást!
  • Szia,
    Köszi, hogy foglalkoztál vele és próbálsz ötletelni.

    1. Eredetileg a programban úgy van. Minden változó típusos deklarálása
    3. A  cells(i,j) formátum nálam lassított a futáson így elvetettem 4.
     5 db értékadásnál használhatsz With SHCELL ... End with

    Ez gyorsított a program futásán 28 perc helyett ~20 perc alatt fut le így köszönöm!

    5. Ezt nem próbáltam, mert időközben meglett a hiba...

    6. Ez is benne volt a programban...köszi szépen.
    A ScreenUpdating-gel párhuzamosan:Application.Calculation = xlCalculationManual/xlCalculationAutomaticApplication.EnableEvents=On/Off
    Mutasd a teljes hozzászólást!
  • Szia!

    találtam egy hibát a ciklusban: For Each SOR_LOT In LOT_RNG

    Pedig a javaslatomban ott volt a végén a .Cells
    Ezzel együtt nem hiszem, hogy ez lenne a lassulás oka, mivel a LOT_RNG egy db oszlop a definíció szerint.
    Más: a kérdés az, hogy a 18 jegyű bárkódban vannak-e vezető nullák?
    Most mennyi a futásidő?
    Üdv.
    Mutasd a teljes hozzászólást!
  • Szia!
    Közben egy kicsit átírtam a korábbi makrómat. A lényeg, hogy a keresést nem a munkalapon, hanem a memóriában végzi, ami elvileg nagyságrendekkel gyorsabb.

    Sub QLOT_data_chk_and_save_uj() Dim LOT_RNG() Dim DATA_RNG() Dim SOR_LOT As Variant, sSor As Long Dim SOR_DATA As Variant Dim LOT, Reference, STATUS, Machine, Scrap_Desc, ScrapID Dim LOT1, LOT2, LOT3, Verzio Dim LOT_DATE As Date Dim LAST_LOT_DATE As Date Dim HELY As String Dim SHFORR As Worksheet, SHCEL As Worksheet Dim asor As Long, bsor As Range On Error Resume Next Application.ScreenUpdating = False asor = Worksheets("Q_DATA_assy").Cells(Rows.Count, 1).End(xlUp) + 1 bsor = Worksheets("SCRs").Cells(Rows.Count, 1).End(xlUp) + 1 Set SHCEL = Worksheets("Q_DATA") SHCEL.Activate DATA_RNG = Application.Transpose(SHCEL.Range(Range("A4"), Range("A4").End(xlDown)).Value) Set SHFORR = Worksheets("Q_LOTS") SHFORR.Activate LOT_RNG = Application.Transpose(SHFORR.Range(Range("A3"), Range("A3").End(xlDown)).Value) For sSor = 1 To UBound(LOT_RNG) Err = 0 With SHFORR SOR_DATA = Application.Match(LOT_RNG(sSor), DATA_RNG, 0) + 3 If Not IsError(SOR_DATA) Then 'Err = 0 Then STATUS = .Range("D" & sSor + 2) Scrap_Desc = .Range("F" & sSor + 2) ScrapID = .Range("E" & sSor + 2) LOT = .Range("M" & sSor + 2) Reference = .Range("I" & sSor + 2) LOT_DATE = .Range("O" & sSor + 2) HELY = Left(.Range("C" & sSor + 2), 5) Verzio = .Range("K" & sSor + 2) LAST_LOT_DATE = SHCEL.Range("H" & SOR_DATA) If LAST_LOT_DATE <> .Range("N" & SOR_DATA) And Reference = .Range("L" & SOR_DATA) Then With SHCEL If .Range(Application.Choose(Application.Match(HELY, Array("FT_BM", "FT_WE", "FT_AS"), 0), "D", "G", "J") & SOR_DATA) = "" Then .Range(Application.Choose(Application.Match(HELY, Array("FT_BM", "FT_WE", "FT_AS"), 0), "D", "G", "J") & SOR_DATA) = LOT .Range(Application.Choose(Application.Match(HELY, Array("FT_BM", "FT_WE", "FT_AS"), 0), "E", "H", "K") & SOR_DATA) = Reference .Range(Application.Choose(Application.Match(HELY, Array("FT_BM", "FT_WE", "FT_AS"), 0), "F", "I", "M") & SOR_DATA) = LOT_DATE If HELY = "FT_AS" Then .Range("L" & SOR_DATA) = Verzio End If .Range("N" & SOR_DATA) = LOT .Range("O" & SOR_DATA) = Reference .Range("P" & SOR_DATA) = LOT_DATE If STATUS = "Active" And HELY = "FT_AS" Then .Range("A" & SOR_DATA & ":U" & SOR_DATA).Copy Destination:=Worksheets("Q_DATA_assy").Cells("A" & asor) asor = asor + 1 .Cells(SOR_DATA, "AX").Value = "X" End If If STATUS = "Scrapped" Then .Range("Q" & SOR_DATA) = STATUS .Range("R" & SOR_DATA) = ScrapID .Range("S" & SOR_DATA) = Scrap_Desc .Range("A" & SOR_DATA & ":U" & SOR_DATA).Copy Destination:=Worksheets("SCRs").Cells("A" & bsor) .Cells(SOR_DATA, "AX").Value = "X" End If End With End If End If End With LOT = "" Reference = "" LOT_DATE = "" Machine = "" Verzio = "" STATUS = "" Next Application.ScreenUpdating = True End Sub
    Érdekelne, hogy így gyorsult-e valamivel.
    Üdv.
    Mutasd a teljes hozzászólást!
  • Szia Fferi,

    A korábbi hiba javítása után a futásidő 80-90s lett, ami már elfogadható érték.
    Sima FOR ciklusba tettem:

    For SOR_LOT_Row = 4 To LOT_RNG.Rows.Count
    A korábbi azért volt rossz, mert a keresett RANGE mérete nem volt definiálva, azaz bármekkorát kereshetett, ha helyes az elméletem. Ez lehet egy cella magas vagy 2 ...3 stb az összes kombinációban. Ez több ezer kombináció.. pl ezer soros oszlop esetén az első sorban pont 1000 kombináció van. a következőnél 999 stb. Így összesen ezer sor esetén 500500 kombináció adódott (Tízezer sor esetén 50005000)

    Az új programod (is) tetszik, biztosan sokat hoz a konyhára, a hét második felében átírom és visszajelzek. A bárkódban nincs vezető nulla, első 5 számjegy standard, utána dátumidő, végén az ellenőrzőszám.


    üdv Ákos
    Mutasd a teljes hozzászólást!
  • Sziasztok, 

    nézetem szerint 2 dolog miatt lassú az excel makró: 
    a) ha olvas táblázatból
    b) ha ír táblázatba 

    a) 
    beolvasod az egész táblázatot egy tömbbe, ez nagyon rossz esetben egy-két másodperc, és a tömbben iszonyat gyorsan tudsz navigálni. 
    datatomb=worksheets(ws_neve).cells(1,1).currentregion.rows
    tomb sorai száma 
    datatombsorszam=worksheets(ws_neve).cells(1,1).currentregion.rows.count
    oszlop ugynez column-al. 
    ha nem egybefüggő a terület, akkor cells().currentregion helyett usedrange

    b) 
    ne cellánként ird ki az eredményt, hanem összeraksz egy stringet, és pozicionálod a kurzort az uj táblázat elejére, és paste metódussal rádobod az egészet. nem nagyságrendi, hanem hatványozott lesz a gyorsulás. pl stringsor="a" & vbtab & "b" és a paste előtt az a1 cellán állsz, akkor az a1be megy az "a" a b1be a "b". tabbal tudsz cellát váltani, és ha jól rémlik vbcrlf-el sort a string kirakásánál. 
    a stringsor paste kirakását kapásból nem tudom fejből, de megtalálod a neten .

    ez a megoldás azt jelenti, hogy az eredmény kb két pillanat alatt fog lefutni. 

    ha nem világos, akkor kérdezz nyugodtan. 


    ez kb azt jelenti
    Mutasd a teljes hozzászólást!
  • Szia Floppy2,

    Köszi, hogy próbálsz segíteni .
    a) Ha figyelmesen megnézed a hozzászólásokat, akkor látod, hogy ez a pont már megvalósult. Igazad van tömbben, memóriában természetesen gyorsabb a keresés. Érdekességképpen a tömb mérete kb. C15 R15000 beolvasása most éppen 8s... (win10 64bit / Excel 32bit)

    b) Hasonlót csináltunk mi is, bár nem szövegben tároltam - nagyon jó ötlet!- hanem egy tömböt töltöttem fel. A kiírása lassú.

    A fentiek ellenére is több, mint egy perc alatt fut le. A forrás táblázat jellemzően 12-15e soros a cél táblázat most éppen 60e sor és bővül.
    Mutasd a teljes hozzászólást!
  • Szia, 

    Bocs, valóban nem olvastam végig az egész levélfolyamot, igy teljesen elképzelhető, hogy olyant irtam ami volt már... 

    viszont az 1 órát leszorítottad 1 perc körülire ez elég jó haladás. 

    a b) pontra kitérve: 
    ha tömbben tárolod a kiirnivalót, akkor az nyilván lassú lesz, mert gondolom a tömb egyes elemei egyes celláknak felelnek meg, igy többszörös a cellahivatkozás. 


    esetleg az utolsó verziót közzétehetnéd, nyilván ha úgy érzed, hogy van még csiszolnivaló rajta...
    Mutasd a teljes hozzászólást!
  • Szia,

    a B. ponthoz. A feltöltés alatt nincs összerendelve semelyik munkalappal vagy cellával. Az összerendelés a teljes ciklus végén valósul meg, amikor "kiírom". Pont úgy csinálom ahogy te írtad a string-el, mindentől függetlenül feltöltöm a tömböt, majd a végén rádobom a memóriában lévő tömbre azt pedig a munkafüzetre.. így gyorsabb mint ha egyből a munkafüzetre dobnám..
    Mutasd a teljes hozzászólást!
  • Szia!

    Ezzel a b-ponttal nekem most asszem elég sokat segítettél, köszi! 
    A legutóbbi office frissítés óta iszonyatosan belassult a cellába írás. Így javult a helyzet.
    Mutasd a teljes hozzászólást!
  • Sziasztok,

    Mindenkinek köszönöm a kitartó és sok segítséget. Több részletből épült fel a végleges program. Mindenki adott hozzá plusz segítséget, sajnos a pontot nem lehet megosztani, így a sok segítség mellett azt is figyelembe vettem, hogy Fferi kezdetektől a megoldáson volt. Remélem elfogadjátok az indoklást. 

    Még egyszer köszönet Nektek.
    Mutasd a teljes hozzászólást!
Tetszett amit olvastál? Szeretnél a jövőben is értesülni a hasonló érdekességekről?
abcd