Prikazi cijelu temu 14.12.2023 19:24
zxz Van mreze
Administrator
Registrovan od:03.02.2009
Lokacija:Tuzla


Predmet:Re:VBA ubrzanje petlje
PreuzmiIzvorni kôd (Visual Basic):
  1. 'PRONALAZI ZADNJI RED
  2. Function zadnji_red(sh As Worksheet)
  3.  
  4.     On Error Resume Next
  5.     zadnji_red = sh.Cells.Find(what:="*", _
  6.                             After:=sh.Range("A1"), _
  7.                             LookAt:=xlPart, _
  8.                             LookIn:=xlFormulas, _
  9.                             SearchOrder:=xlByRows, _
  10.                             SearchDirection:=xlPrevious, _
  11.                             MatchCase:=False).Row
  12.     On Error GoTo 0
  13. End Function
  14. Function kombinacije()
  15. Dim i As Integer, n As Integer, m As Integer, z As Integer, Broj_Redova As Integer
  16. Dim sit As Worksheet
  17.  
  18. Dim a As Single
  19. a = Timer
  20. Set sit = ActiveSheet
  21. Broj_Redova = zadnji_red(sit)
  22. sit.Range("L1:O" & Broj_Redova).ClearContents
  23. 'Broj_Redova = 5500
  24. ReDim podaci(Broj_Redova, 6) As Integer
  25.  
  26. For i = 1 To Broj_Redova
  27.     For n = 1 To 6
  28.     podaci(i, n) = Cells(i, n)
  29.     Next n
  30. Next i
  31. For i = 1 To Broj_Redova - 1
  32.      For z = i + 1 To Broj_Redova
  33.         broj_istih = 0
  34.         For n = 1 To 6
  35.             For m = 1 To 6
  36.                 If podaci(i, n) = podaci(z, m) Then
  37.                 broj_istih = broj_istih + 1
  38.                 Exit For
  39.                 End If
  40.             Next m
  41.             If n - broj_istih > 1 Then
  42.             Exit For
  43.             End If
  44.         Next n
  45.                 If broj_istih = 5 Then
  46.                 Cells(i, 13) = Cells(i, 13) & z & ","
  47.                 Cells(z, 13) = Cells(z, 13) & i & ","
  48.                 ElseIf broj_istih = 6 Then
  49.                 Cells(i, 15) = Cells(i, 15) & z & ","
  50.                 Cells(z, 15) = Cells(z, 15) & i & ","
  51.                 End If
  52.      Next z
  53.  
  54. Next i
  55. MsgBox (Timer - a)
  56. End Function
Podrška samo putem foruma, jer samo tako i ostali imaju koristi od toga.