CheckBox ile istenen verileri yazdırmak

[darkvenge0]

Merhaba arkadaşlar,
Excel VBA üzerinden checkbox'larda seçtiğim seçeneklere göre o işlemi yapmasını veya yapmamasını istiyorum fakat, klasör seçtiğim için asıl liste fonksiyonunda hata alıyorum. Resim
Ekteki resimde onayladıklarımın başka bir excel dosyasındaki (VeriGiriş olarak tanımlanan) birden fazla excelde aynı kısma yazılması üzerine çalışıyorum fakat seçtiğim kısmı kodun içine yerleştiremedim.
**Sub subcribt out of range hatası alıyorum. Her türlü yardıma açığım teşekkürler.

###Module Kısmı
Dim Klasor As Object
Dim Obj As Object
Dim Kaynak As String
Dim Sayfa_Adı As String
Public Sub Fonksiyon1()
On Error Resume Next
Dim Baslik As String
MsgBox ("Deneme ")
Baslik = "Kaynak Dosyaları İçeren Klasörü Seçin"
Set Obj = CreateObject("shell.application")
Set Klasor = Obj.browseforfolder(0, Baslik, 50, &H0)
Kaynak = Klasor.Items.Item.Path
If Not Klasor Is Nothing Then
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
On Error Resume Next
Liste (Klasor.Items.Item.Path)
MsgBox "işlem tamam"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
Set Obj = Nothing
Set Klasor = Nothing
Exit Sub
Hata: MsgBox Err.Description, vbExclamation, "Error #" & Err.Number
End Sub

Public Sub Liste(Yol As String)
Dim fL As Object, f As Object, Dosya As String, j As Long
Set fL = CreateObject("Scripting.FileSystemObject").getfolder(Yol).SubFolders
Dim wb As Workbook
Dosya = Dir(Yol & "\*.*")
Application.ScreenUpdating = False
While Dosya <> ""
DoEvents
If ThisWorkbook.Name <> Dosya Then
Set wb = Workbooks.Open(Kaynak & "\" & Dosya)
Application.DisplayAlerts = False
dosya_adı = ActiveWorkbook.Name
Sayfa_Adı = ActiveSheet.Name
For r = 1 To ActiveWorkbook.Sheets.Count
sayfaadi = Workbooks(dosya_adı).Sheets(r).Name
    Public Sub degerler_grub1()
        Worksheets("VeriGiriş").Cells(5, 5).Value = Sayfa1.Range("D5")  ### **Sub subcript out of range hatası aldığım nokta
        Worksheets("VeriGiriş").Cells(6, 5).Value = Sayfa1.Range("D6")
        Worksheets("VeriGiriş").Cells(5, 7).Value = Sayfa1.Range("F5")
        Worksheets("VeriGiriş").Cells(6, 7).Value = Sayfa1.Range("F6")
    End Sub
    Public Sub degerler_grub2()
        Worksheets("VeriGiriş").Cells(15, 5).Value = Sayfa1.Range("D7")
        Worksheets("VeriGiriş").Cells(16, 5).Value = Sayfa1.Range("D8")
        Worksheets("VeriGiriş").Cells(17, 5).Value = Sayfa1.Range("D9")
        Worksheets("VeriGiriş").Cells(19, 5).Value = Sayfa1.Range("D10")
    End Sub
    Public Sub degerler_grub3()
        Worksheets("VeriGiriş").Cells(20, 5).Value = Sayfa1.Range("D11")
        Worksheets("VeriGiriş").Cells(20, 6).Value = Sayfa1.Range("E11")
        Worksheets("VeriGiriş").Cells(22, 5).Value = Sayfa1.Range("D12")
        Worksheets("VeriGiriş").Cells(10, 9).Value = Sayfa1.Range("D13")
    End Sub
    Public Sub degerler_grub4()
        Worksheets("VeriGiriş").Cells(10, 10).Value = Sayfa1.Range("D14")
        Worksheets("VeriGiriş").Cells(10, 12).Value = Sayfa1.Range("D15")
        Worksheets("VeriGiriş").Cells(10, 13).Value = Sayfa1.Range("D16")
    End Sub
Next
Application.DisplayAlerts = True
wb.Save
wb.Close False
End If
Dosya = Dir
Wend
On Error GoTo sonraki
For Each f In fL
Kaynak = f.Path
Liste (f.Path)
sonraki:
Next
Set fL = Nothing
End Sub


###Sayfa1 Kısmı Checkboxlar ve 1 adet butonum var


Private Sub CommandButton1_Click()
Fonskiyon1
End Sub

Public Sub CheckBox1_Click()
If CheckBox1.Value = True Then
degerler_grub1
End If
End Sub
Public Sub CheckBox2_Click()
If CheckBox2 = True Then
degerler_grub2
End If
End Sub
Public Sub CheckBox3_Click()
If CheckBox3 = True Then
degerler_grub3
End If
End Sub
Public Sub CheckBox4_Click()
If CheckBox4 = True Then
degerler_grub4
End If
End Sub