Seçime Göre Onay Kutusuna İşaret Koyma

[ercan_bora]

Selamlar,

Düşeyara ile sistem türünü seçim yaptığımda ilgili ürünlerin onay kutusunun tikli olmasını istiyorum. Böylece tik atıldığı zaman adet kısmına otomatik olarak 1 yazdırabileyim.

Ekteki örnekte, manuel seçilince manuel olan ilk 2 ürün tik olmalı, motorlu seçilince ise manuellerin onay tiki kalkmalı ve motorluların onay tiki olması gerekir.

Örnek dosya ektedir:
http://s8.dosya.tc/server5/meadlk/Kitap1.xlsx.html

Mümkün müdür böyle bir şey yapmak ?




Bu konu burada paylaşıldı fakat bir sonuç alamadığım için tekrardan burada açtım.
http://www.excel.web.tr/f14/secime-gore-onay-kutusuna-aret-koyma-t168893.html

 

[ercan_bora]

Bir Allah'ın kulu yok mu yardımcı olabilecek yada imkansız bişey mi sordum bilmiyorum

 

[halit3]

bu kod işini görürmü

Sub Nesneleriekle()

On Error Resume Next

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
Picture.Delete
End If
Next Picture

sut = "d"
For r = 2 To s1.Cells(Rows.Count, "e").End(3).Row  'kisi_sayisi + 1
If s1.Cells(r, "e").Value <> "" Then
yer = s1.CheckBoxes.Add(1, 1, 1, 1).Name
'yer1 = Selection.ShapeRange.AlternativeText
s1.Shapes(yer).OLEFormat.Object.Top = s1.Cells(r, sut).Top + 4 ' + say
s1.Shapes(yer).OLEFormat.Object.Left = s1.Cells(r, sut).Left
s1.Shapes(yer).OLEFormat.Object.Height = s1.Cells(r, sut).Height - 8
s1.Shapes(yer).OLEFormat.Object.Width = s1.Cells(r, sut).Width - 4
s1.Shapes(yer).OLEFormat.Object.Characters.Text = "" ' Cells(r, "e").Value
If Mid(Cells(r, "e").Value, 1, 6) = "Manuel" Then s1.Shapes(yer).OLEFormat.Object.Value = xlOn

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

End Sub

 

[ercan_bora]

Hocam eline sağlık fakat hiçbir seçim yapmıyor. Dosyayı ekledim benmi hata yapıyorum anlamadım. makro olarak kaydettim.

http://s4.dosya.tc/server5/ot87jg/Kitap1.rar.html

 

[halit3]

Sayfaya form denetim kutusundan bir komut duğmesi ekle ve makroyu komut düğmesine bağla sonrada çalıştır.

kodun çalışma işlevi şöyle siz gerekli seçim işlemlerini yaptıktan sonra kodu çalıştırın ve sonuçları gözlemleyin.

 

[ercan_bora]

Elinize sağlık fakat tam beceremedim. Makrodan da anlaşıldığı üzere ben eğer bu seçenekleri 100 e yakın yaparsam makro formülünü de ona göre çoğlatmam gerekecek o yüzden aşacak gibi duruyor.projeyi derleyim topliyim ondan sonra tekrardan daha net olacak şekilde yardım alırım sizden teşekkürler elinize sağlık...

 

[halit3]

Birde bu kodu dene

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [c2:c100]) Is Nothing Then Exit Sub
If Target.Column <> 3 Then Exit Sub
Set s1 = Sheets(ActiveSheet.Name)
Dim Picture As Object
For Each Picture In s1.Shapes
'If Picture.Type = 8 Then
If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object) = "CheckBox" Then
If Val(Picture.TopLeftCell.Row) = Target.Row And TypeName(s1.Shapes(Picture.Name).OLEFormat.Object) = "CheckBox" Then
If Mid(Cells(Target.Row, "c").Value, 1, 6) = "Manuel" Then
s1.Shapes(Picture.Name).OLEFormat.Object.Value = xlOn
Else
s1.Shapes(Picture.Name).OLEFormat.Object.Value = xlof
End If
End If
End If
Next Picture
End Sub