Dim TercihSira() As String
Dim SiraRS As New ADODB.Recordset
Dim SiraSql As String
Dim i, x, xArr As Integer
 
'REDIM PRESERVE TercihSira(i) As String  'REDIM PRESERVE... eski değerleri koruyarak dizinin boyutunu değiştirir
'REDIM  TercihSira(i) As String          'REDIM ... eski değerleri silerek  dizinin boyutunu değiştirir
 
SiraSql = "select * from tercih order by [puan] desc" ' öğrencileri puana göre sırala
SiraRS.Open "tercih", CurrentProject.Connection, adOpenKeyset, adLockOptimistic
If SiraRS.RecordCount < 1 Then Exit Sub 'tablo boşsa çık
SiraRS.MoveFirst
Do While Not SiraRS.EOF
i=0
For x = 0 To SiraRS.Fields.Count - 1 '
    If SiraRS.Fields(x).Name Like "sinif*" And (Not IsNull(SiraRS.Fields(x))) Then i = i + 1
Next x
ReDim TercihSira(i)
 
For x = 0 To SiraRS.Fields.Count - 1 '
    If SiraRS.Fields(x).Name Like "sinif*" And (Not IsNull(SiraRS.Fields(x))) Then
        TercihSira(SiraRS.Fields(x)) = SiraRS.Fields(x).Name
    End If
Next x
 
For xArr = 1 To i
If SiraRS.Fields(2) <> "" Then Exit For
If DCount("*", "tercih", "sonuc='" & TercihSira(xArr) & "'") >= DLookup("kontenjan", "sinif", "sinif='" & TercihSira(xArr) & "'") Then GoTo 10
CurrentDb.Execute "update tercih set sonuc='" & TercihSira(xArr) & "' where AdayTC=" & SiraRS.Fields(0)
10
Next xArr
 
SiraRS.MoveNext
Loop
 
SiraRS.Close: Set SiraRS = Nothing