Excel ile Tercih Robotu Hazırlama

Sub TERCIH()
Set v = Sheets("veri sayfası"): Set k = Sheets("kontenjanlar"): Set s = Sheets("sonuçlar")
s.Range("B2:F" & Rows.Count).ClearContents
Application.Calculation = xlCalculationManual
sonsut = v.Cells(1, Columns.Count).End(xlToLeft).Column
sonsat = v.Cells(Rows.Count, "A").End(3).Row
alan = Range(Cells(2, "A"), Cells(sonsat, sonsut)).Address
v.Range(alan).Sort v.[B1], 2
For sat = 2 To v.Cells(Rows.Count, "B").End(3).Row
    s.Cells(sat, "B") = v.Cells(sat, "A"): s.Cells(sat, "D") = v.Cells(sat, "B")
    For sut = 3 To sonsut
        Set kont = k.[B:B].Find(v.Cells(sat, sut))
        If Not kont Is Nothing Then
            dolu = WorksheetFunction.CountIf(s.Range("F2:F" & sat), k.Cells(kont.Row, "B"))
            If k.Cells(kont.Row, "C") - dolu > 0 Then
                s.Cells(sat, "F") = k.Cells(kont.Row, "B")
                kon = Empty: kalan = 0: GoTo 10
            Else: s.Cells(sat, "F") = "YERLEŞEMEDİNİZ"
            End If
        End If
    Next
10: Next
Application.Calculation = xlCalculationAutomatic
MsgBox "Yerleştirme işlemi tamamlandı, hayırlı olsun..", vbInformation, "..:: Ömer BARAN ::.."
End Sub

Sub exceldestek()
Application.ScreenUpdating = False
    Dim veri As Worksheet: Dim kont As Worksheet: Dim sonuc As Worksheet
    Set veri = Worksheets("veri sayfası")
    Set kont = Worksheets("kontenjanlar")
    Set sonuc = Worksheets("sonuçlar")
        Set con = CreateObject("Adodb.Connection")
        Set rs = CreateObject("Adodb.Recordset")
            kont.Columns(3).Copy kont.Columns(4)
            con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
            ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=no"""
                sorgu = "select * from [" & veri.Name & "$A2:AF] where f1 is not null order by f2 desc "
                rs.Open sorgu, con, 1, 1
                    If rs.RecordCount > 0 Then
                        sonuc.Range("A2:F" & veri.Cells(Rows.Count, 1).End(xlUp).Row).ClearContents
                        sat = 2
        Do While Not rs.EOF
            sonuc.Cells(sat, 2) = rs("f1").Value
            sonuc.Cells(sat, 4) = rs("f2").Value
                For sut = 3 To 32
                    tercih = rs("f" & sut).Value
                    If tercih = "" Then Exit For
                        Set kt = kont.Range("B2:B" & kont.Cells(Rows.Count, 2).End(xlUp).Row).Find(tercih)
                            If Not kt Is Nothing Then
                                If kont.Cells(kt.Row, 4) >= 1 Then
                                    sonuc.Cells(sat, 6) = tercih
                                    kont.Cells(kt.Row, 4) = kont.Cells(kt.Row, 4) - 1
                                    Exit For
                                Else
                                    sonuc.Cells(sat, 6) = "Yerleşemediniz"
                                End If
                            End If
                    kt = Empty
                Next
    sat = sat + 1
        rs.movenext
        Loop
                    End If
            rs.Close: con.Close
        Set rs = Nothing: Set con = Nothing
    MsgBox "İşlem tamam...." & vbNewLine & vbNewLine & WorksheetFunction.Sum(kont.Columns(4)) & " Kontejan boş kaldı", vbInformation, "metehan8001"
Application.ScreenUpdating = True
End Sub