Dolu olan satırın yanına checkbox koymak

[bornovalı1]

Arkadaşlar merhaba;

Eğer a sutünu dolu ise d sutünunda her satırın yanına bir checkbox koymak istiyorum.
Günlük olarak a sutünuna ilave yaptıkça checkbox kendiliğinden ilave olaması için bir kod ihtiyacım var yardımcı olabilirmisiniz

Teşekkürler

 

[Ömer]

Merhaba,

Çalışma sayfası kod bölümüne kopyalayınız. A1:A10 arasına değer girdiğinizde yan sütuna checkbox ekler. Veri sildiğinizde checkboxu siler.

Private Sub Worksheet_Change(ByVal Target As Range)

    If Intersect(Target, Range("A1:A10")) Is Nothing Then Exit Sub

    On Error Resume Next
   
    With Target.Offset(0, 3)
        If Target <> "" Then
             With ActiveSheet.OLEObjects.Add("Forms.CheckBox.1", _
                Left:=.Left, Top:=.Top, Width:=.Width, Height:=.Height)
                .Name = Target.Address
            End With
        Else
            ActiveSheet.Shapes.Range(Array(Target.Address)).Delete
        End If
    End With
    
End Sub

.

 

[bornovalı1]

Üstadım emeğine sağlık
Chek koyunca e sutununa var veya yok gibi bir şey yazdırma imkanı olabilirmi?

Taksit taksit oldu ama halledebilirim diye düşündüm ama malesef yapamadım

 

[Ömer]

Öncelikle eski kodları silin, daha sonra yazdığım ilgili bölümlere kodları kopyalayın.

Sayfanın kod bölümüne:

Private Sub Worksheet_Change(ByVal Target As Range)

    If Intersect(Target, Range("A1:A10")) Is Nothing Then Exit Sub
    
    Application.ScreenUpdating = False
    On Error Resume Next
   
    With Target.Offset(0, 3)
        If Target <> "" Then
            .Offset(0, 1) = "Yok"
            ActiveSheet.Shapes.Range(Array(Target.Address(0, 0) & "ek")).Delete
            With ActiveSheet.OLEObjects.Add("Forms.CheckBox.1", _
                Left:=.Left, Top:=.Top, Width:=.Width, Height:=.Height)
                .Name = Target.Address(0, 0) & "ek"
            End With
        Else
            ActiveSheet.Shapes.Range(Array(Target.Address(0, 0) & "ek")).Delete
            .Offset(0, 1).ClearContents
            Application.SendKeys "{ENTER}"
        End If
    End With
    
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

    If Intersect(Target, Range("A1:A10")) Is Nothing Then Exit Sub
    Call Var_Yok
    
End Sub

ThisWorkbook(Bu çalışma kitabı) bölümüne:

Dim chk() As New Class1

Private Sub Workbook_Open()

    Dim a As Long, nesne As Object
    
    a = 0
    For Each nesne In Sheets("Sayfa1").OLEObjects
        If TypeName(nesne.Object) = "CheckBox" Then
            a = a + 1
            ReDim Preserve chk(a)
            Set chk(a).chk = nesne.Object
        End If
    Next nesne
    
End Sub

Module ekleyin ve aşağıdaki kopyalayın.

Dim chk() As New Class1
Sub Var_Yok()

    Dim a As Long, nesne As Object
    
    a = 0
    For Each nesne In Sheets("Sayfa1").OLEObjects
        If TypeName(nesne.Object) = "CheckBox" Then
            a = a + 1
            ReDim Preserve chk(a)
            Set chk(a).chk = nesne.Object
        End If
    Next nesne

End Sub

Class modul ekleyip aşağıdakileri kopyalayın.

Public WithEvents chk As MSForms.CheckBox
Private Sub chk_Click()

    Dim hcr As String, adr As String

    adr = WorksheetFunction.Substitute(chk.Name, "ek", "")
    hcr = Sheets("Sayfa1").Shapes(chk.Name).TopLeftCell.Address
    
    If chk.Value = True Then
        Range(adr).Offset(0, 5).Previous = "Var"
    Else
        Range(adr).Offset(0, 5).Previous = "Yok"
    End If
    
End Sub

.

 

[bornovalı1]

Üstadım eline sağlık ama söyle bir sıkıntı var;

Toplu olarak yapıştırma yapmam gerekiyor , böyle olduğu zaman da toplu bir checkBox koyuyor.
Tek tek eklediğimde sorun yok gibi ama 250 tane veri ekleyince hepsini bir tanede birleştiriyor.
Yardımcı olabilirmisiniz?

 

[bornovalı1]

Bİrde checkBox otamatik olarak konulduğunda yok olarak yazması olabilirmi ? olmazsa çokta sorun değil
Teşekkür ederim