Makroya Onay Kutusu

[igultekin2000]

iyi günler; çok kullandığım bu makroda onay kutusu kullanmak istiyorum. Bu mümkün olabilir mi. Kullandığım makro ;

Sub aktarr()
Application.ScreenUpdating = False
On Error Resume Next
Sheets("LISTE").Range("a3:ı65536").ClearContents
Sheets("LISTE").Range("a3:ı65536").Interior.ColorIndex = xlNone

Set s1 = ThisWorkbook.Worksheets("LISTE")

Set s2 = ThisWorkbook.Worksheets("2014")
sonsatir = s1.Range("c65536").End(xlUp).Row + 1
sonn = s2.Range("ı65536").End(xlUp).Row
If WorksheetFunction.CountIf(s2.Range("ı2:ı" & sonn), s1.Cells(2, "c")) >= 2 Then
For k = 1 To 9
s1.Cells(sonsatir, k) = s2.Cells(2, k)
s1.Cells(sonsatir, k).Interior.ColorIndex = s2.Cells(2, k).Interior.ColorIndex
Next k
End If
For i = 2 To s2.Range("ı65536").End(xlUp).Row
If s2.Cells(i, "ı") = s1.Cells(2, "c") Then
sonsatir = s1.Range("c65536").End(xlUp).Row + 1
For k = 1 To 9
s1.Cells(sonsatir, k) = s2.Cells(i, k)
Next k
End If
Next i


Set s2 = ThisWorkbook.Worksheets("2015")
sonsatir = s1.Range("c65536").End(xlUp).Row + 1
sonn = s2.Range("ı65536").End(xlUp).Row
If WorksheetFunction.CountIf(s2.Range("ı2:ı" & sonn), s1.Cells(2, "c")) >= 2 Then
For k = 1 To 9
s1.Cells(sonsatir, k) = s2.Cells(2, k)
s1.Cells(sonsatir, k).Interior.ColorIndex = s2.Cells(2, k).Interior.ColorIndex
Next k
End If
For i = 2 To s2.Range("ı65536").End(xlUp).Row
If s2.Cells(i, "ı") = s1.Cells(2, "c") Then
sonsatir = s1.Range("c65536").End(xlUp).Row + 1
For k = 1 To 9
s1.Cells(sonsatir, k) = s2.Cells(i, k)
Next k
End If
Next i
    
Set s2 = ThisWorkbook.Worksheets("2016")
sonsatir = s1.Range("c65536").End(xlUp).Row + 1
sonn = s2.Range("ı65536").End(xlUp).Row
If WorksheetFunction.CountIf(s2.Range("ı2:ı" & sonn), s1.Cells(2, "c")) >= 2 Then
For k = 1 To 9
s1.Cells(sonsatir, k) = s2.Cells(2, k)
s1.Cells(sonsatir, k).Interior.ColorIndex = s2.Cells(2, k).Interior.ColorIndex
Next k
End If
For i = 2 To s2.Range("ı65536").End(xlUp).Row
If s2.Cells(i, "ı") = s1.Cells(2, "c") Then
sonsatir = s1.Range("c65536").End(xlUp).Row + 1
For k = 1 To 9
s1.Cells(sonsatir, k) = s2.Cells(i, k)
Next k
End If
Next i

Set s2 = ThisWorkbook.Worksheets("2017")
sonsatir = s1.Range("c65536").End(xlUp).Row + 1
sonn = s2.Range("ı65536").End(xlUp).Row
If WorksheetFunction.CountIf(s2.Range("ı2:ı" & sonn), s1.Cells(2, "c")) >= 2 Then
For k = 1 To 9
s1.Cells(sonsatir, k) = s2.Cells(2, k)
s1.Cells(sonsatir, k).Interior.ColorIndex = s2.Cells(2, k).Interior.ColorIndex
Next k
End If
For i = 2 To s2.Range("ı65536").End(xlUp).Row
If s2.Cells(i, "ı") = s1.Cells(2, "c") Then
sonsatir = s1.Range("c65536").End(xlUp).Row + 1
For k = 1 To 9
s1.Cells(sonsatir, k) = s2.Cells(i, k)
Next k
End If
Next i
Application.ScreenUpdating = True
MsgBox "İşlem TAMAM.", vbInformation
End Sub