Ardışık komut hk.

[ITouch87]

Merhaba;

J3'ten J10'a kadar hücreler mevcut.Bu hücrelerde checkboxlarım var.tıkladığım her satırındaki checkbox
,aynı satırdaki j hücresine günün tarihini koymaktadır.Yani j3'e tıkladığımda j3 hücresinde tanımladığım tarihi yazıyor.

bu formülü "j3'ten j10'a checkbox 1'den Checkbox 10'a kadar tek macro ile nasıl yazabilirim.Aksi takdirde aşağıdaki gibi ayrı ayrı yazmam gerekiyor.Yardımcı olabilir misiniz?

Private Sub CheckBox1_Click()
If CheckBox1 = True Then
Range("A1").Select
    Selection.Copy
    Range("J3").Select
    Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
        xlNone, SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Else
   [J3].Value = ""
End If

End Sub
Private Sub CheckBox2_Click()
If CheckBox2 = True Then
Range("A1").Select
    Selection.Copy
    Range("J4").Select
    Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
        xlNone, SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Else
   [J4].Value = ""
End If
End Sub
Private Sub CheckBox3_Click()
If CheckBox3 = True Then
Range("A1").Select
    Selection.Copy
    Range("J5").Select
    Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
        xlNone, SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Else
   [J5].Value = ""
End If
End Sub
Private Sub CheckBox4_Click()
If CheckBox4 = True Then
Range("A1").Select
    Selection.Copy
    Range("J6").Select
    Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
        xlNone, SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Else
   [J6].Value = ""
End If
End Sub

 

[chngrcn]

deneyiniz..

Sub deneme()
For i = 1 To 10
If ActiveSheet.OLEObjects("CheckBox" & i).Object.Value = True Then
Range("A1").Select
    Selection.Copy
    Cells(i, "J").Select
 Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
        xlNone, SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Else
   Cells(i, "J").Value = ""
End If

Next
End Sub

 

[ITouch87]

Uyguladım ancak maalesef sonuç alamadım.Ek dosyayın inceler misiniz?

Link

 

[chngrcn]

https://upterabit.com/1Kry/Kitap155.xlsm

Ben denedim oluyor..

Ayrıca a1 hücresinden neden tarihi aldırttırıyorsunuz ki ?
yaptığınız yöntemle sistemi yormaktan başka bişey yapmıyorsunuz..

direkt olarak hücrelere " date" formülüne eşitleyebiliriz, isterseniz tabi..

 

[halit3]

örnek dosyanız ile ilgili aşağıdaki kodu çalıştırın bütün nesneler silinmiş olacak.

Sub Nesneleri_sil2()
Dim Picture As Object
For Each Picture In ActiveSheet.Shapes
Picture.Delete
Next Picture
End Sub

sonra bu makroyu çalıştır.

Sub Nesneleriekle()

On Error Resume Next
Set s1 = Sheets(ActiveSheet.Name)
For r = 1 To s1.Shapes.Count
If TypeName(s1.Shapes(r).OLEFormat.Object) = "CheckBox" Then
a = MsgBox("Nesneler mevcut yeniden nesneleri oluşturmak istiyorsanız" & Chr(10) & Chr(10) & _
"Nesneleri sil seçeneğine tıkladıktan sonra yeniden deneyiniz.", vbInformation, " U Y A R I ")
Exit Sub
End If
Next

say = 0
For i = 10 To 13
For r = 3 To 102  'kisi_sayisi + 1
say = say + 1
yer = s1.CheckBoxes.Add(1, 1, 1, 1).Name
'yer1 = Selection.ShapeRange.AlternativeText
s1.Shapes(yer).OLEFormat.Object.Top = s1.Cells(r, i).Top + 4 ' + say
s1.Shapes(yer).OLEFormat.Object.Left = s1.Cells(r, i).Left
s1.Shapes(yer).OLEFormat.Object.Height = s1.Cells(r, i).Height - 8
s1.Shapes(yer).OLEFormat.Object.Width = s1.Cells(r, i).Width - 4
s1.Shapes(yer).OLEFormat.Object.Name = "CheckBox" & say '"" ' Cells(r, "u").Value
s1.Shapes(yer).OLEFormat.Object.Characters.Text = "" ' Cells(r, "u").Value
Next r
Next i
deneme

'sh.Range("A1").Select
MsgBox "İşlem Tamam", vbInformation, " U Y A R I "

End Sub

bunu da makrolar bölümüne koy

Sub resimsec()
Dim i, sat, sut
sat = ActiveSheet.Shapes(Application.Caller).BottomRightCell.Row
sut = ActiveSheet.Shapes(Application.Caller).BottomRightCell.Column

Dim Picture As Object
Set s1 = Sheets(ActiveSheet.Name)
For Each Picture In s1.Shapes

If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object) = "CheckBox" Then
If Picture.BottomRightCell.Row = sat Then
If Picture.BottomRightCell.Column = sut Then
If s1.Shapes(Picture.Name).OLEFormat.Object.Value = 1 Then
Cells(sat, sut).Value = Cells(1, 1).Value
Else
Cells(sat, sut).Value = ""
End If
' = xlOn
End If
End If
End If
Next Picture
End Sub

en yukarıdaki kodu bir defalığına kullanacaksınız daha sonra onu silin bu kodu kullanabilirsiniz.

Sub Nesneleri_sil()
Dim Picture As Object
For Each Picture In ActiveSheet.Shapes
If TypeName(ActiveSheet.Shapes(Picture.Name).OLEFormat.Object) = "CheckBox" Then
Picture.Delete
End If
Next Picture

End Sub

sonra nesnelere tıklayın sonucu gözlemleyin.