hücre değerine göre onay kutusu ekleme

[spacebar]

değerli üstadlarım,
A sutununda değer var ise h sutununda onay kutusu ekleyen bir makroya ihtiyacım var. yani değişen bir form sayfam var. örneğin a2 den a50 ye kadar veri varsa h2 den h50 ye kadar onay kutusu ekleyebilirmi. yardımlarınız için teşekkürler...

 

[EmrExcel16]

Deneyiniz..

Sub Checkboxes_Ekle()
    For i = 2 To Cells(Rows.Count, 1).End(3).Row
        If Cells(i, "A") <> "" Then
            Set Hcr = Cells(i, "H")
            Set Check = ActiveSheet.CheckBoxes.Add(Hcr.Left, Hcr.Top, Hcr.Width, Hcr.Height)
            Check.Caption = ""
        End If
    Next
    MsgBox "Islem tamam"
End Sub

 

[spacebar]

üstad yine hızır gibi yetiştiniz. çok kısa sade bir kod. teşekkür ederim. ellerinize sağlık.

 

[serdar.gul]

@EmrExcel16

benimde işime yarayacağını düşündüğüm bir kod yazmışsınız öncelikle teşekkürler ama dediğinizi denedi

 

[serdar.gul]

@EmrExcel16

benimde işime yarayacağını düşündüğüm bir kod yazmışsınız öncelikle teşekkürler ama onay kutusu çıktıktan sonra işaret koyup tekrar kodu çalıştırdığımızda onay işaretini kaldırmaktadır

 

[EmrExcel16]

üstad yine hızır gibi yetiştiniz. çok kısa sade bir kod. teşekkür ederim. ellerinize sağlık.

Rica ederim , iyi çalışmalar.

 

[EmrExcel16]

@EmrExcel16

benimde işime yarayacağını düşündüğüm bir kod yazmışsınız öncelikle teşekkürler ama onay kutusu çıktıktan sonra işaret koyup tekrar kodu çalıştırdığımızda onay işaretini kaldırmaktadır

Merhaba Serdar bey , aşağıdaki şekilde deneyiniz..

Sub Checkboxes_Ekle()
    For i = 2 To Cells(Rows.Count, 1).End(3).Row
        If Cells(i, "A") <> "" Then
            Set Hcr = Cells(i, "H")
            If ChkVrm(Hcr) Then
                Set Check = ActiveSheet.CheckBoxes.Add(Hcr.Left, Hcr.Top, Hcr.Width, Hcr.Height)
                Check.Caption = ""
            End If
        End If
    Next
    MsgBox "Islem tamam"
End Sub
Function ChkVrm(Hcr)
    ChkVrm = True
    For Each ChkBox In ActiveSheet.CheckBoxes
        If ChkBox.TopLeftCell.Address = Hcr.Address Then
            ChkVrm = False
            Exit Function
        End If
    Next
End Function

 

[serdar.gul]

@EmrExcel16

şimdi oldu teşekkürler

 

[EmrExcel16]

@EmrExcel16

şimdi oldu teşekkürler

Rica ederim , iyi çalışmalar.