Új hozzászólás Aktív témák

• #18992 Mutt senior tag hallgat #18980

  Új Válasz 2013-09-17 22:02:46 #18992

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Mutt

  senior tag

  válasz hallgat #18980 üzenetére

  Hello,

  A megoldásom egy másik módszert használ, az eredeti lapból csak a hasznos (ahol a cella nem üres vagy 0) adatokat átemeli egy másik lapra (a neve output, de lent állíthatod ezt).

  Egyszerre 3 sor hasznos adatát egy tömbben tárolja. A sor végén pedig kiíratja a másik lapra a tömböt. Utána 3 sorral feljebb megy és azon is végig megy és kiír.

  Nekem 11-16 másodperc alatt lefut egy 1422x190-es táblán, remélem nálad is rendben fog menni.
  Kommenteltem, hogy könnyen javítható legyen.

  Sub Torol3asaval()
  Dim arrEredmeny() 'dinamikus tömb az értékek tárolásához
  Const LastRow As Integer = 1422 'utolsósor
  Const LastColumn As Integer = 190 'utolsóoszlop
  Dim vRow As Long 'változó a vizsgált sorok nyomonkövetéséhez
  Dim vColumn As Long 'változó a vizsgált oszlopok nyomonkövetéséhez
  Dim vHits As Long 'változó a soronként a feltételeknek megfelelő eredményekhez
  Dim i As Long
  Dim vStartTime
  Dim wsOutput As Worksheet
  Const wsName As String = "output" 'ide tesszük az eredményt
  Dim wsActiveSheet As String
  
  'nézzük meg mennyi idő alatt fut le
  vStartTime = Time
  
  'elmentjük az eredeti lapot
  wsActiveSheet = ActiveSheet.Name
  
  'megnézzük hogy van-e a keresett névvel munkalap a füzetben
  For i = 1 To Sheets.Count
  If Sheets(i).Name = wsName Then vHits = 1
  Next i
  
  'ha nincs akkor létrehozzuk a lapot, különben megnyitjuk
  If vHits <> 1 Then
  Set wsOutput = Sheets.Add
  wsOutput.Name = wsName
  Else
  Set wsOutput = Sheets(wsName)
  wsOutput.Cells.Clear
  End If
  
  'visszamegyünk az eredti lapra
  Sheets(wsActiveSheet).Activate
  
  'kikapcsoljuk a képernyő frissítést hogy gyorsabb legyen
  Application.ScreenUpdating = False
  
  'utolsó sortól elindulunk vissza
  For vRow = LastRow To 1 Step -3
  'töröljük a tömb tartalmát
  Erase arrEredmeny
  'ide gyűjtük hogy hány oszlop van ahol nem üres vagy 0 van az utolsó sorban
  vHits = 0
  'végig megyünk a sor oszlopain
  For vColumn = 1 To LastColumn
  'ha az érték nem üres vagy nulla akkor egy tömbbe elmentjük a sor és feletti 2 értéket
  If Cells(vRow, vColumn).Value <> 0 And Cells(vRow, vColumn).Value <> "" Then
  'növeljük a sikeres találatok számlálóját
  vHits = vHits + 1
  'átméretezzük a tömböt hogy új találatokat is tudjon tárolni
  ReDim Preserve arrEredmeny(1 To 3, 1 To vHits)
  arrEredmeny(1, vHits) = Cells(vRow - 2, vColumn).Value
  arrEredmeny(2, vHits) = Cells(vRow - 1, vColumn).Value
  arrEredmeny(3, vHits) = Cells(vRow, vColumn).Value
  End If
  Next vColumn
  
  'kiírjuk a találatokat, ha van mit
  If vHits Then
  'az első 3 sor elé újabb 3 sort szúrunk be
  wsOutput.Rows("1:3").Insert Shift:=xlDown
  For i = 1 To vHits
  With wsOutput
  'az első 3 sorba beírjuk a korábbi találatokat
  .Cells(1, i) = arrEredmeny(1, i)
  .Cells(2, i) = arrEredmeny(2, i)
  .Cells(3, i) = arrEredmeny(3, i)
  End With
  Next i
  End If
  Next vRow
  
  'visszakapcsoljuk a frissítést
  Application.ScreenUpdating = True
  
  Debug.Print "Futási idő: " & Format(Time - vStartTime, "s") & " sec"
  End Sub

  üdv

  A tanácsaimat ingyen adom. Ha nem tetszik, akkor kérlek ne kritizáld! / https://github.com/viszi/codes/tree/master/Excel

Új hozzászólás Aktív témák