Alt Alta Onay Kutusu Ekleme Sorunu

[emrearik]

Merhabalar arkadaşlar. Basit bi excel projesinde K sütünundan aşağı itibaren alt alta 2000 tane onay kutusu çoğaltmak istiyorum ve yan tarafa doğru veya yanlış olarak yazdırılmasını istiyorum. Çok uğraştım fakat makro bilgim çok kısıtlı olduğu için çözemedim. Yardımcı olabilirseniz çok sevinirim. Altın üye değilim dosyaları farklı bir yere upload ederseniz memnun olurum.

Proje linki : https://drive.google.com/file/d/0B-KWh6Itm3xTM0drVVl5Sm9KR1k/view?usp=sharing

 

[halit3]

Kırmızı yere ne yazarsanız o kadar nesne ekliyecektir.

kod:

Sub Nesne_ekle()

Dim Picture As Object
Set s1 = Sheets(ActiveSheet.Name)

sut = 11 'sutun indizi yani K sütun numarası
For r = 2 To [COLOR="Red"]46[/COLOR]
yer = s1.CheckBoxes.Add(1, 1, 1, 1).Name
s1.Shapes(yer).OLEFormat.Object.Top = s1.Cells(r, sut).Top + 4
s1.Shapes(yer).OLEFormat.Object.Left = s1.Cells(r, sut).Left + 30
s1.Shapes(yer).OLEFormat.Object.Height = s1.Cells(r, sut).Height - 8
s1.Shapes(yer).OLEFormat.Object.Width = 15 's1.Cells(r, sut).Width
s1.Shapes(yer).OLEFormat.Object.Value = xlOff
s1.Shapes(yer).OLEFormat.Object.Characters.Text = "" ' Cells(1, sut2).Value
s1.Shapes(yer).OLEFormat.Object.LinkedCell = s1.Cells(r, sut + 1).Address
s1.Shapes(yer).OLEFormat.Object.Display3DShading = False
Next r
MsgBox "İşlem Tamam", vbInformation, " U Y A R I "
End Sub

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
MsgBox "İşlem Tamam", vbInformation, " U Y A R I "
End Sub

Sub hepsinisec()
On Error Resume Next
sut = 11 'sutun indizi yani K sütun numarası
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.Column = sut Then
s1.Shapes(Picture.Name).OLEFormat.Object.Value = xlOn
End If
End If
Next Picture
MsgBox "İşlem Tamam", vbInformation, " U Y A R I "
End Sub

Sub hepsinibirak()
On Error Resume Next
sut = 11 'sutun indizi yani K sütun numarası
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.Column = sut Then
s1.Shapes(Picture.Name).OLEFormat.Object.Value = xlOff
End If
End If
Next Picture
MsgBox "İşlem Tamam", vbInformation, " U Y A R I "
End Sub

 

[Merhum İdris SERDAR]

.

Buradaki dosyaya bakın.

http://www.excelgurusu.com/coklu-onay-kutusu-checkbox/

.