Onay kutucuğu - hepsini seç hepsini sil

[bydogannn]

Arkadaslar kolay gelsın;

ektekı dosyada onay kutucuklarının hepsını secmek veya secılılerın hepsini kaldırmayı nasıl yapabılırız

 

[halit3]

kod

Sub hepsini_sec()
Set s1 = Sheets(ActiveSheet.Name)
Dim Picture As Object
For Each Picture In s1.Shapes
If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object) = "CheckBox" Then
s1.Shapes(Picture.Name).OLEFormat.Object.Value = xlOn
End If
Next Picture
End Sub

Sub hepsini_kaldır()
Set s1 = Sheets(ActiveSheet.Name)
Dim Picture As Object
For Each Picture In s1.Shapes
If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object) = "CheckBox" Then
s1.Shapes(Picture.Name).OLEFormat.Object.Value = xlOff
End If
Next Picture
End Sub

 

[Merhum İdris SERDAR]

.

Aşağıda kodu kullanabilirsiniz.

Sub Sil()

    Dim Obj As Object
    For Each Obj In ActiveSheet.DrawingObjects
    Obj.Delete
    Next Obj
    
End Sub

Ayrıca buradaki örneği inceleyin.

http://www.excel.web.tr/f60/checkbox-onay-kutusu-option-buton-secenek-duomesi-t69739.html


.
.

 

[bydogannn]

merhabalar,

İdris bey yardımlarınız ıcın tesekkür ederım ama yanlış anlaşıldım galıba verdığınz kodla onayları kaldırmadı CheckBox' ları hep sıldı halit beyın verdığı kod benım ıstediğim mantıkta ama çok kasıyo bunu nasıl düzeltebılırız

yardımlarınızı beklıyorum

 

[Merhum İdris SERDAR]

.

Bunu deneyin.

Sub Macro1()
    Columns("E:E").ClearContents
    Range("A1").Select
End Sub

Makroya da gerek olmadan, E sütun başlığına basıp, seçili hale geldiğinde DELETE tuşuna basın.

.

.

 

[bydogannn]

tamda istediğim buydu idris bey emeğinize sağlık

 

[halit3]

Alternatif olarak aşağıdaki kodları denermisiniz.
önce (nesne_sil) makrosunu çalıştırın sonra da (nesne_ekle) makrosunu çalıştırın.

Sub nesne_sil()
Set s1 = Sheets(ActiveSheet.Name)
Dim Picture As Object
'On Error Resume Next
For Each Picture In ActiveSheet.Shapes
If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object) = "CheckBox" Then
Picture.Delete
End If

Next Picture
End Sub

Sub nesne_ekle()

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 düğmesine tıkladıktan sonra yeniden deneyiniz.", vbInformation, " U Y A R I ")
Exit Sub
End If
Next

sut = "A"
say = 2

For r = 3 To s1.Cells(Rows.Count, "B").End(3).Row
say = say + 1
yer = s1.CheckBoxes.Add(1, 1, 1, 1).Name
s1.Shapes(yer).OLEFormat.Object.Top = s1.Cells(say, sut).Top + 4
s1.Shapes(yer).OLEFormat.Object.Left = s1.Cells(say, sut).Left
s1.Shapes(yer).OLEFormat.Object.Height = s1.Cells(say, sut).Height - 8
s1.Shapes(yer).OLEFormat.Object.Width = 12
's1.Shapes(yer).OLEFormat.Object.Characters.Text = "Seç" 's1.Cells(r, "B").Value
s1.Shapes(yer).OLEFormat.Object.Name = "B" & r - 2
s1.Shapes(yer).OLEFormat.Object.Value = xlOff
s1.Shapes(yer).OLEFormat.Object.LinkedCell = s1.Cells(say, "e").Address
s1.Cells(say, "e").Value = "YANLIŞ"
s1.Shapes(yer).OLEFormat.Object.Display3DShading = False
s1.Cells(say, "a").Value = "Seç"

Next r

MsgBox "İşlem Tamam", vbInformation, " U Y A R I "
End Sub


Sub hepsini_sec()
Set s1 = Sheets(ActiveSheet.Name)
Dim Picture As Object
For Each Picture In s1.Shapes
If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object) = "CheckBox" Then
s1.Shapes(Picture.Name).OLEFormat.Object.Value = xlOn
End If
Next Picture
End Sub

Sub hepsini_kaldır()
Set s1 = Sheets(ActiveSheet.Name)
Dim Picture As Object
For Each Picture In s1.Shapes
If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object) = "CheckBox" Then
s1.Shapes(Picture.Name).OLEFormat.Object.Value = xlOff
End If
Next Picture
End Sub