Onay kutusu Çoğaltma

[serkan.sevinc]

Merhaba,

İlk belirtmiş olduğum konuya gerek kalmadı. Teşekkürler.
Ben ekteki şekilde kendimce bişeyler yaptım. Fakat eksiklerim var. Eksiklerim aşağıdaki şekildedir.

-B sütununda tarih bulunmaktadır. C Sütununa isim yazıldığında tarih otomatik olarak gelmektedir. Ama bir gün sonrası bu tarih yine değişecektir. Bu sebeple yarın olduğunda tarihin bugünün tarihi olarak kalmasını istiyorum.
-Diğer konu ise onay kutularını elle manuel çoğaltmak çok uzun sürecektir. Diğer satırlara otomatik nasıl çoğaltırım.

Teşekkürler

 

[Necdet]

Merhaba,

Aşağıdaki kodları ilgili sayfanın kod bölümüne koplayıp deneyiniz.
C sütununda değişiklik olduğunda B sütununa tarih yazar.
Onay kutularını da D:O sütuna ekler.

Private Sub Worksheet_Change(ByVal Target As Range)

    If Intersect(Target, [C:C]) Is Nothing Or Target.Row < 5 Then Exit Sub
    
'http://www.mrexcel.com/forum/excel-questions/180887-add-checkboxes-through-visual-basic-applications-code.html
    Dim Rng         As Range
    Dim ToRow       As Long
    Dim MyLeft      As Double
    Dim MyTop       As Double
    Dim MyHeight    As Double
    Dim MyWidth     As Double
    '--------------------------
    Application.ScreenUpdating = False
    
    If Target.Value = "" Then Exit Sub
    Target.Offset(0, -1) = Date
    
    For Each Rng In Range("D" & Target.Row & ":O" & Target.Row)
        'If Not IsEmpty(Cells(ToRow, "D")) Then
        '-
            MyLeft = Rng.Left
            MyTop = Rng.Top
            MyHeight = Rng.Height
    '        MyWidth = Rng.Width
            MyWidth = MyHeight = Rng.Width
            
            ActiveSheet.CheckBoxes.Add(MyLeft, MyTop, MyWidth, MyHeight).Select
            With Selection
                .Caption = ""
                .Value = xlOff
                .LinkedCell = Rng.Address
                .Display3DShading = False
            End With
        ' End If
    Next Rng
    
    Application.ScreenUpdating = True

End Sub

 

[serkan.sevinc]

çok çok teşekkür ederim

 

[Necdet]

Rica ederim, güle güle kullanınız.

 

[Necdet]

Merhaba,

İlk verdiğim kodlara ek yaptım.

C sütununda hücre silindiğinde onay kutuları da silinir.
Ayrıca sıra numarasını vermesini de sağladım.

Artık hangisini kullanırsanız.

Private Sub Worksheet_Change(ByVal Target As Range)

    If Intersect(Target, [C:C]) Is Nothing Or Target.Row < 5 Or Selection.Count > 1 Then Exit Sub
    
'http://www.mrexcel.com/forum/excel-questions/180887-add-checkboxes-through-visual-basic-applications-code.html
    Dim Rng         As Range
    Dim ToRow       As Long
    Dim MyLeft      As Double
    Dim MyTop       As Double
    Dim MyHeight    As Double
    Dim MyWidth     As Double
    Dim oShape      As Shape

    '--------------------------
    Application.ScreenUpdating = False
    
    If Target.Value = "" Then
 
        For Each oShape In ActiveSheet.Shapes
            If Not Application.Intersect(oShape.TopLeftCell, ActiveSheet.Range("D" & Target.Row & ":O" & Target.Row)) Is Nothing Then oShape.Delete
        Next
        
        Range("A" & Target.Row & ":B" & Target.Row).ClearContents
        Range("D" & Target.Row & ":O" & Target.Row).ClearContents
        
    End If
    
    Target.Offset(0, -1) = Date
    Target.Offset(0, -2) = Target.Row - 4
    
    '---- Daha önceki checkboxları siler
    Range("D" & Target.Row & ":O" & Target.Row).ClearContents
    For Each oShape In ActiveSheet.Shapes
        If Not Application.Intersect(oShape.TopLeftCell, ActiveSheet.Range("D" & Target.Row & ":O" & Target.Row)) Is Nothing Then oShape.Delete
    Next
    '---- Daha önceki checkboxları silindi
    
    For Each Rng In Range("D" & Target.Row & ":O" & Target.Row)
        'If Not IsEmpty(Cells(ToRow, "D")) Then
        '-
            MyLeft = Rng.Left
            MyTop = Rng.Top
            MyHeight = Rng.Height
    '        MyWidth = Rng.Width
            MyWidth = MyHeight = Rng.Width
            
            ActiveSheet.CheckBoxes.Add(MyLeft, MyTop, MyWidth, MyHeight).Select
            With Selection
                .Caption = ""
                .Value = xlOff
                .LinkedCell = Rng.Address
                .Display3DShading = False
            End With
        ' End If
    Next Rng
    
    Application.ScreenUpdating = True

End Sub