Kodun bir bölümünü CheckBox.1 tuşuna bağlama

Katılım
24 Şubat 2009
Mesajlar
733
Beğeniler
4
Excel Vers. ve Dili
2003
#1
Merhaba arkadaşlar; Elimde bir kod var aşağıda;
Sub Analiz()
Application.ScreenUpdating = False
On Error Resume Next
Set s1 = ThisWorkbook.Worksheets("İZİNLER")
s1.Range("m2:O65536").ClearContents
For i = 2 To s1.Range("B65536").End(xlUp).Row
s1.Cells(i, "m") = s1.Cells(i, "k") - s1.Cells(i, "g")
If s1.Cells(i, "g") = s1.Cells(i, "k") Then s1.Cells(i, "m") = 1

For K = 1 To s1.Cells(i, "m")
sonsatir = s1.Range("N65536").End(xlUp).Row + 1
s1.Cells(sonsatir, "N") = s1.Cells(i, "B") & " " & (s1.Cells(i, "G") + K - 1)
Next K
Next i

Set s2 = ThisWorkbook.Worksheets("PUANTAJ")
For i = 7 To s2.Range("A65536").End(xlUp).Row
s2.Range("F" & i & ":AJ" & i).ClearContents
Next i
sonsatir = s1.Range("N65536").End(xlUp).Row

For i = 7 To s2.Range("E65536").End(xlUp).Row
For K = 6 To 36
aranan = s2.Cells(i, "E") & " " & s2.Cells(6, K)
'If s2.Cells(6, K) <> "" And Format(s2.Cells(6, K), "dddd") <> "Pazar" Then
s2.Cells(i, K) = 1 'Bir rakamı yazıyor.
'End If
If WorksheetFunction.CountIf(s1.Range("N2:N" & sonsatir), aranan) >= 1 Then s2.Cells(i, K) = ""
Next K
Next i
Application.ScreenUpdating = True
End Sub
Kırmızı ile işaretlediğim kodu bir CheckBox.1 nesnesine bağlamak istiyorum, yani CheckBox.1 aktif olunca Yani centik koyduğumda Kırmızı satırlardaki kod çalışacak, centiği kaldırınca kırmızı satırlardaki kod gösterildiği gibi çalışmayacak. Teşekkürler.
 
Katılım
29 Ekim 2018
Mesajlar
24
Beğeniler
0
Excel Vers. ve Dili
2016TR
#2
İlgili kod alanını aşağıdaki kod bloğu ile değiştirerek deneyiniz.

If s2.Cells(6, K) <> "" And Format(s2.Cells(6, K), "dddd") <> "Pazar" and CheckBox1.Value = True Then
s2.Cells(i, K) = 1 'Bir rakamı yazıyor.
'End If



ASUS_Z00LD cihazımdan Tapatalk kullanılarak gönderildi
 

dalgalikur

Destek Ekibi
Destek Ekibi
Katılım
5 Haziran 2006
Mesajlar
2,079
Beğeniler
214
Excel Vers. ve Dili
2013
#5
Merhaba
kod satırı şöyle olmalı. Checkbox un hangi sayfada olduğunu belirtmelisiniz.

Kod:
If s2.Cells(6, k) <> "" And Format(s2.Cells(6, k), "dddd") <> "Pazar" And Sayfa7.CheckBox1.Value = True Then
 

dalgalikur

Destek Ekibi
Destek Ekibi
Katılım
5 Haziran 2006
Mesajlar
2,079
Beğeniler
214
Excel Vers. ve Dili
2013
#7
Yeni kodlar tam olarak şöyle olmalı.

Kod:
Sub Analiz()
    Application.ScreenUpdating = False
    On Error Resume Next
    Set s1 = ThisWorkbook.Worksheets("İZİNLER")
    s1.Range("N2:O65536").ClearContents
    For i = 2 To s1.Range("B65536").End(xlUp).Row
        For k = 1 To s1.Cells(i, "H") + s1.Cells(i, "I")
            sonsatir = s1.Range("N65536").End(xlUp).Row + 1
            s1.Cells(sonsatir, "N") = s1.Cells(i, "B") & (s1.Cells(i, "G") + k - 1)
        Next k
    Next i
    Set s2 = ThisWorkbook.Worksheets("PUANTAJ")
    For i = 7 To s2.Range("A65536").End(xlUp).Row
        s2.Range("F" & i & ":AJ" & i).ClearContents
    Next i
    sonsatir = s1.Range("N65536").End(xlUp).Row
    For i = 7 To s2.Range("E65536").End(xlUp).Row
        For k = 6 To 36
        aranan = s2.Cells(i, "E") & s2.Cells(6, k)
        If s2.Cells(6, k) <> "" Then
            If Format(s2.Cells(6, k), "dddd") <> "Pazar" Then
                s2.Cells(i, k) = 1
            End If
            If Sayfa7.CheckBox1.Value = True Then
                s2.Cells(i, k) = 1
            End If
        End If
        If WorksheetFunction.CountIf(s1.Range("N2:N" & sonsatir), aranan) >= 1 Then s2.Cells(i, k) = ""
        Next k
    Next i
    Application.ScreenUpdating = True
    MsgBox "BORDRO OLUŞTURULDU.", vbInformation
End Sub
 
Üst