• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Onay Kutusu Çoğaltma

S

SERPICO1

Katılım
21 Haziran 2008
Mesajlar
17
Excel Vers. ve Dili
Excel Türkçe 2010
Arkadaşlar, ekli resimde görüldüğü gibi onay kutularından oluşan bir tablom var. Ancak bu onay kutuları yüzlerce satırda olmak zorunda... Haliyle bunları denetimi ile birlikte kopyala-yapıştır ile çoğaltmak mümkün değil.

Onay kutularımı 100 yada 200 satır denetimiyle birlikte oluşturabileceğim bir VB kodu-makro var mı?

Not: Neden x işareti koyarak halletmiyorsun diye sormayın çünkü böylesi gerekli...
 

Ekli dosyalar

  • Tablo.jpg
    Tablo.jpg
    93.3 KB · Görüntüleme: 28
Bu resimden bir şey anlaşılmıyor örnek bir dosya ekleyin onay kutularınıda ekliyeceğiniz yerleri belirtin ve onay kutuları hangi hücrede ne gibi bir işlem yapacak bunu belirtin.
 
halit3' Alıntı:
Bu resimden bir şey anlaşılmıyor örnek bir dosya ekleyin onay kutularınıda ekliyeceğiniz yerleri belirtin ve onay kutuları hangi hücrede ne gibi bir işlem yapacak bunu belirtin.
Genişletmek için tıkla ...

Sadece onay kutularını K7:AT100 aralığında bir kereliğine çoğaltmak istiyorum. Malum manuel olarak denetimleri tek tek tanımlamak zor.

Tabiiki onay kutuları seçildiğinde AV7:CE100 aralığına denetim sonuçları doğru-yanlış şeklinde yansıyacak şekilde...

İlginize teşekkürler.
 

Ekli dosyalar

SERPICO' Alıntı:
Sadece onay kutularını K7:AT100 aralığında bir kereliğine çoğaltmak istiyorum. Malum manuel olarak denetimleri tek tek tanımlamak zor.

Tabiiki onay kutuları seçildiğinde AV7:CE100 aralığına denetim sonuçları doğru-yanlış şeklinde yansıyacak şekilde...

İlginize teşekkürler.
Genişletmek için tıkla ...

kod:

Kod: 
Sub Nesne_ekle()

Dim Picture As Object
Set s1 = Sheets(ActiveSheet.Name)
sat = 8
sut = 37
For r = 11 To 46
yer = s1.CheckBoxes.Add(1, 1, 1, 1).Name
s1.Shapes(yer).OLEFormat.Object.Top = s1.Cells(sat, r).Top
s1.Shapes(yer).OLEFormat.Object.Left = s1.Cells(sat, r).Left - 2
s1.Shapes(yer).OLEFormat.Object.Height = s1.Cells(sat, r).Height
s1.Shapes(yer).OLEFormat.Object.Width = s1.Cells(sat, r).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(sat - 1, r + sut).Address
s1.Shapes(yer).OLEFormat.Object.Display3DShading = False
Next r

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
End Sub
 
Sayın halit3;
Kod gayet başarılı ve istediğimi gerçekleştirmemi sağlar nitelikte... Yardımınız için teşekkür ederim.

Ancak kod 'sat = 8' değeriyle sadece 8. satıra onay kutusu atıyor. Ben bu koddaki sat = 8 değerini sırayla 10, 12, 14, 16, ..., 100 yaparak istediğim tüm satırlara onay kutusu koymayı başardım. En azından saatlerce tek tek onay kutusu denetimi oluşturmaktan kurtardı beni...

Ama ilerde işine yarayacak arkadaşlar olabilir düşüncesiyle kodu tek çalıştırmada 8., 10., 12., 14., 16., ..., 100. satırlara onay kutusu atayacak hale getirilebilir mi?

Tekrar teşekkürler ve iyi çalışmalar...
 
SERPICO' Alıntı:
Sayın halit3;
Kod gayet başarılı ve istediğimi gerçekleştirmemi sağlar nitelikte... Yardımınız için teşekkür ederim.

Ancak kod 'sat = 8' değeriyle sadece 8. satıra onay kutusu atıyor. Ben bu koddaki sat = 8 değerini sırayla 10, 12, 14, 16, ..., 100 yaparak istediğim tüm satırlara onay kutusu koymayı başardım. En azından saatlerce tek tek onay kutusu denetimi oluşturmaktan kurtardı beni...

Ama ilerde işine yarayacak arkadaşlar olabilir düşüncesiyle kodu tek çalıştırmada 8., 10., 12., 14., 16., ..., 100. satırlara onay kutusu atayacak hale getirilebilir mi?

Tekrar teşekkürler ve iyi çalışmalar...
Genişletmek için tıkla ...

Aşağıdaki kodun kırmızı bölümünü isterseniz silebilirsiniz.

kod:

Kod: 
Sub Nesne_ekle()

Set s1 = Sheets(ActiveSheet.Name)
sut = 37
sat = 8
son = s1.Cells(Rows.Count, "B").End(3).Row + 1

For i = sat To son Step 2

For r = 11 To 46

yer = s1.CheckBoxes.Add(1, 1, 1, 1).Name
s1.Shapes(yer).OLEFormat.Object.Top = s1.Cells(i, r).Top
s1.Shapes(yer).OLEFormat.Object.Left = s1.Cells(i, r).Left - 2
s1.Shapes(yer).OLEFormat.Object.Height = s1.Cells(i, r).Height
s1.Shapes(yer).OLEFormat.Object.Width = s1.Cells(i, r).Width
s1.Shapes(yer).OLEFormat.Object.Value = xlOff
s1.Shapes(yer).OLEFormat.Object.Characters.Text = "" ' Cells(1, r).Value
s1.Shapes(yer).OLEFormat.Object.LinkedCell = s1.Cells(i - 1, r + sut).Address
[COLOR="Red"]s1.Cells(i - 1, r + sut).Value = "YANLIŞ"[/COLOR]
s1.Shapes(yer).OLEFormat.Object.Display3DShading = False

[COLOR="Red"]say = say + 1
s1.Shapes(yer).OLEFormat.Object.Name = "Onay Kutusu " & say[/COLOR]

Next r

Next i
MsgBox "işlem tamam"

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
End Sub

şuan B sütunundaki son dolu satıra kadar işlem yapıyor.

Kod: 
son = s1.Cells(Rows.Count, "B").End(3).Row + 1

kodun burasında kendiniz son satırı belirtebilirsiniz.
Kod: 
son =100
 
Bu ne hız.
Çok teşekkürler ilginize...

Gerçekten forumda baya bi aramıştım, çok isteyen de olmuş bu tür bi kodu... Herkese kaynaklık eder umarım.
 
merhabalar,

ben bir dosyada birden fazla onay kutusu ekledim ve şimdi bunların bir kısmını silmek istiyorum. kolonu silince kolondaki herşeyi siliyor ancak onay kutuları silinmiyor ve yandaki kolana kayıyor. toplu olarak silebileceğim bir yöntem var mıdır?

teşekkürler
Hakan
 
fersa' Alıntı:
merhabalar,

ben bir dosyada birden fazla onay kutusu ekledim ve şimdi bunların bir kısmını silmek istiyorum. kolonu silince kolondaki herşeyi siliyor ancak onay kutuları silinmiyor ve yandaki kolana kayıyor. toplu olarak silebileceğim bir yöntem var mıdır?

teşekkürler
Hakan
Genişletmek için tıkla ...

Sayfadaki bütün nesneleri silen kod

Kod: 
ActiveSheet.DrawingObjects.Delete
 
fersa' Alıntı:
merhabalar,

ben bir dosyada birden fazla onay kutusu ekledim ve şimdi bunların bir kısmını silmek istiyorum. kolonu silince kolondaki herşeyi siliyor ancak onay kutuları silinmiyor ve yandaki kolana kayıyor. toplu olarak silebileceğim bir yöntem var mıdır?

teşekkürler
Hakan
Genişletmek için tıkla ...

bu bütün onay kutularını siler

Kod: 
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
 
Bu kod Activex nesnelerine ait üçüncu sutundaki nesneleri siler

Kod: 
Sub Nesneleri_sil()
Dim Picture As Object
For Each Picture In ActiveSheet.Shapes
If TypeName(ActiveSheet.Shapes(Picture.Name).OLEFormat.Object) = "OLEObject" Then
If TypeName(ActiveSheet.Shapes(Picture.Name).OLEFormat.Object.Object) = "CheckBox" Then
If Picture.BottomRightCell.Column = [COLOR="Red"]3[/COLOR] Then
Picture.Delete
End If
End If
End If
Next Picture

End Sub
 
Bu kod Activex nesnelerine ait beşinci satırdaki nesneleri siler


Kod: 
Sub Nesneleri_sil()
Dim Picture As Object
For Each Picture In ActiveSheet.Shapes
If TypeName(ActiveSheet.Shapes(Picture.Name).OLEFormat.Object) = "OLEObject" Then
If TypeName(ActiveSheet.Shapes(Picture.Name).OLEFormat.Object.Object) = "CheckBox" Then
If Picture.BottomRightCell.Row = [COLOR="Red"]5[/COLOR] Then
Picture.Delete
End If
End If
End If
Next Picture

End Sub
 
Bu kod form nesnelerine ait üçüncü sutündaki nesneleri siler

Kod: 
Sub Nesneleri_sil()
Dim Picture As Object
For Each Picture In ActiveSheet.Shapes
If TypeName(ActiveSheet.Shapes(Picture.Name).OLEFormat.Object) <> "OLEObject" Then
If TypeName(ActiveSheet.Shapes(Picture.Name).OLEFormat.Object) = "CheckBox" Then
If Picture.BottomRightCell.Column = [COLOR="red"]3[/COLOR] Then
Picture.Delete
End If
End If
End If
Next Picture
End Sub
 
Bu kod form nesnelerine ait sekizinci satırdaki nesneleri siler

Kod: 
Sub Nesneleri_sil()
Dim Picture As Object
For Each Picture In ActiveSheet.Shapes
If TypeName(ActiveSheet.Shapes(Picture.Name).OLEFormat.Object) <> "OLEObject" Then
If TypeName(ActiveSheet.Shapes(Picture.Name).OLEFormat.Object) = "CheckBox" Then
If Picture.BottomRightCell.Row = [COLOR="red"]8[/COLOR] Then
Picture.Delete
End If
End If
End If
Next Picture
End Sub
 
Merhaba benim de aynı bu şekilde bir sorunum var fakat kodu uygulayamadım. Yardımcı olabilir misiniz acaba?

halit3' Alıntı:
Aşağıdaki kodun kırmızı bölümünü isterseniz silebilirsiniz.

kod:

Kod: 
Sub Nesne_ekle()

Set s1 = Sheets(ActiveSheet.Name)
sut = 37
sat = 8
son = s1.Cells(Rows.Count, "B").End(3).Row + 1

For i = sat To son Step 2

For r = 11 To 46

yer = s1.CheckBoxes.Add(1, 1, 1, 1).Name
s1.Shapes(yer).OLEFormat.Object.Top = s1.Cells(i, r).Top
s1.Shapes(yer).OLEFormat.Object.Left = s1.Cells(i, r).Left - 2
s1.Shapes(yer).OLEFormat.Object.Height = s1.Cells(i, r).Height
s1.Shapes(yer).OLEFormat.Object.Width = s1.Cells(i, r).Width
s1.Shapes(yer).OLEFormat.Object.Value = xlOff
s1.Shapes(yer).OLEFormat.Object.Characters.Text = "" ' Cells(1, r).Value
s1.Shapes(yer).OLEFormat.Object.LinkedCell = s1.Cells(i - 1, r + sut).Address
[COLOR="Red"]s1.Cells(i - 1, r + sut).Value = "YANLIŞ"[/COLOR]
s1.Shapes(yer).OLEFormat.Object.Display3DShading = False

[COLOR="Red"]say = say + 1
s1.Shapes(yer).OLEFormat.Object.Name = "Onay Kutusu " & say[/COLOR]

Next r

Next i
MsgBox "işlem tamam"

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
End Sub

şuan B sütunundaki son dolu satıra kadar işlem yapıyor.

Kod: 
son = s1.Cells(Rows.Count, "B").End(3).Row + 1

kodun burasında kendiniz son satırı belirtebilirsiniz.
Kod: 
son =100
Genişletmek için tıkla ...
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst