Nöbet listesi hazırlayan kodda revize yapmak

Sub yeni()
    Dim veri(170), detay(170, 4, 6), aranan(24, 4) As Variant
    deger = 0
satir = 0
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
For i = 8 To 62 Step 6
    Sayfa18.Range("B" & i & ":X" & i + 3).Clear
Next i

For i = 3 To 36 Step 6
    For ii = 1 To 30 Step 6
        For ia = 0 To 3 ' kişi
            veri(deger) = Sayfa17.Cells(i + ia, ii)
            For ib = 0 To 4 ' sütun değerleri
                detay(deger, ib, 0) = Sayfa17.Cells(i + ia, ii + ib + 1) 'isim alındı
                detay(deger, ib, 1) = Sayfa17.Cells(i + ia, ii + ib + 1).Font.Bold ' yazı kalın mı
                detay(deger, ib, 2) = Sayfa17.Cells(i + ia, ii + ib + 1).Font.Italic ' yazı italik mi
                detay(deger, ib, 3) = Sayfa17.Cells(i + ia, ii + ib + 1).Font.Color ' yazı rengi
                detay(deger, ib, 4) = Sayfa17.Cells(i + ia, ii + ib + 1).Font.Name ' yazı ailesi
                detay(deger, ib, 5) = Sayfa17.Cells(i + ia, ii + ib + 1).Font.Size ' yazı boyutu
                detay(deger, ib, 6) = Sayfa17.Cells(i + ia, ii + ib + 1).Interior.Color ' arkaplan rengi
            Next ib
            deger = deger + 1
        Next ia
    Next ii
Next i

For i = 2 To Sayfa14.Cells(Rows.Count, 1).End(3).Row
    If CDate(Sayfa14.Cells(i, 1)) = CDate(Sayfa18.Cells(1, "t")) Then
        satir = i
        Exit For
    End If
Next i

If satir = "" Then
    MsgBox "Tarih bulunmamıştır.", vbInformation, "TAHSİN ANARAT | idariişleruzmanı"
    Exit Sub
End If

deger = 0
For i = 2 To 101 Step 4
    aranan(deger, 0) = Sayfa14.Cells(1, i)
    For ii = 0 To 3
        For ia = 0 To 170
            If CStr(Sayfa14.Cells(satir, i + ii)) = CStr(veri(ia)) Then
                aranan(deger, ii + 1) = ia
                ia = 170
            End If
        Next ia
    Next ii
    deger = deger + 1
Next i

For i = 7 To 67 Step 6
    For ii = 2 To 24 Step 6
        For ia = 0 To 24
            If CStr(Sayfa18.Cells(i, ii)) = CStr(aranan(ia, 0)) Then
                For ib = 1 To 4 ' bulunan alanın alt alta isimleri getirme
                    For ic = 0 To 4 ' bulunan alanın sütunları arasında gezinti
                        If IsEmpty(aranan(ia, ib)) Then GoTo devam
                        Sayfa18.Cells(i + ib, ii + ic) = detay(aranan(ia, ib), ic, 0)
                        Sayfa18.Cells(i + ib, ii + ic).Font.Bold = detay(aranan(ia, ib), ic, 1)
                        Sayfa18.Cells(i + ib, ii + ic).Font.Italic = detay(aranan(ia, ib), ic, 2)
                        Sayfa18.Cells(i + ib, ii + ic).Font.Color = detay(aranan(ia, ib), ic, 3)
                        Sayfa18.Cells(i + ib, ii + ic).Font.Name = detay(aranan(ia, ib), ic, 4)
                        Sayfa18.Cells(i + ib, ii + ic).Font.Size = detay(aranan(ia, ib), ic, 5)
                        Sayfa18.Cells(i + ib, ii + ic).Interior.Color = detay(aranan(ia, ib), ic, 6)
                        devam::
                    Next ic
                Next ib
            End If
        Next ia
    Next ii
Next i

For i = 8 To 67 Step 6
    Sayfa18.Range("B" & i & ":F" & i + 3).Borders.LineStyle = 1
    Sayfa18.Range("h" & i & ":l" & i + 3).Borders.LineStyle = 1
    Sayfa18.Range("n" & i & ":r" & i + 3).Borders.LineStyle = 1
    Sayfa18.Range("t" & i & ":x" & i + 3).Borders.LineStyle = 1
Next i

Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
MsgBox "..:: | Bitti | ::..", vbInformation, "TAHSİN ANARAT | idariişleruzmanı"
End Sub