Predmet:Re:VBA ubrzanje petlje
PreuzmiIzvorni kôd (Visual Basic):'PRONALAZI ZADNJI RED
Function zadnji_red(sh As Worksheet)
On Error Resume Next
zadnji_red = sh.Cells.Find(what:="*", _
After:=sh.Range("A1"), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
Function kombinacije()
Dim i As Integer, n As Integer, m As Integer, z As Integer, Broj_Redova As Integer
Dim sit As Worksheet
Dim a As Single
a = Timer
Set sit = ActiveSheet
Broj_Redova = zadnji_red(sit)
sit.Range("L1:O" & Broj_Redova).ClearContents
'Broj_Redova = 5500
ReDim podaci(Broj_Redova, 6) As Integer
For i = 1 To Broj_Redova
For n = 1 To 6
podaci(i, n) = Cells(i, n)
Next n
Next i
For i = 1 To Broj_Redova - 1
For z = i + 1 To Broj_Redova
broj_istih = 0
For n = 1 To 6
For m = 1 To 6
If podaci(i, n) = podaci(z, m) Then
broj_istih = broj_istih + 1
Exit For
End If
Next m
If n - broj_istih > 1 Then
Exit For
End If
Next n
If broj_istih = 5 Then
Cells(i, 13) = Cells(i, 13) & z & ","
Cells(z, 13) = Cells(z, 13) & i & ","
ElseIf broj_istih = 6 Then
Cells(i, 15) = Cells(i, 15) & z & ","
Cells(z, 15) = Cells(z, 15) & i & ","
End If
Next z
Next i
MsgBox (Timer - a)
End Function
Podrska samo putem foruma, jer samo tako i ostali imaju koristi od toga.