[ÇÖZÜLDÜ] CheckBoxes Cell link Copy & Paste SORUNU

[turist]

Sayfada bulunan checkbox'lar belirli hücrelere linklidir.(TRUE / FALSE)
Bunların bulunduğu hücreyi kopyalayıp başka hücrelere yapıştırdığımda ;
linklerin hücre değerleri değişmiyor.
Formül uygulamalarında olduğu gibi , kopyalarken bu değerleri değişen hücrelere nasıl uygulayabiliriz?

Ekli dosyada örnek uygulama ve açıklamaları belirttim.

İlgilenen ve cevap verenlere, şimdiden saygılarımla teşekkür ederim.

 

[halit3]

Makro ile yapılabilir

Kod:

Sub Nesne_ekle()
Dim Picture As Object
Set sh = Sheets(ActiveSheet.Name)
sut3 = "b"
For r = 1 To (sh.Cells(Rows.Count, "a").End(3).Row - 1) * 4 'kisi_sayisi + 1
sol = sh.Cells(r, sut3).Left + son
orta = sh.Cells(r, sut3).Top + 4
gen = 40
yuk = sh.Cells(r, sut3).Height - 4
sh.CheckBoxes.Add(sol, orta, gen, yuk).Characters.Text = ""
Next r
sut = 2
r = 3
son = 0
sat = 2
Set s1 = Sheets(ActiveSheet.Name)
For Each Picture In s1.Shapes
If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object) = "CheckBox" Then
s1.Shapes(Picture.Name).OLEFormat.Object.Top = s1.Cells(sat, sut).Top + 4 ' + say
s1.Shapes(Picture.Name).OLEFormat.Object.Left = s1.Cells(sat, 2).Left + son
s1.Shapes(Picture.Name).OLEFormat.Object.Height = s1.Cells(sat, sut).Height - 8
s1.Shapes(Picture.Name).OLEFormat.Object.Width = 40 's1.Cells(s, sut).Width
s1.Shapes(Picture.Name).OLEFormat.Object.Characters.Text = Cells(1, sut + 1).Value
s1.Shapes(Picture.Name).OLEFormat.Object.Value = xlOff
s1.Shapes(Picture.Name).OLEFormat.Object.LinkedCell = s1.Cells(sat, sut + 1).Address
s1.Shapes(Picture.Name).OLEFormat.Object.Display3DShading = False
sut = sut + 1
son = son + 50
If sut = 6 Then
r = r + 1
sut = 2
son = 0
sat = sat + 1
End If
End If
Next Picture
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
End Sub
 
 
Sub hepsini_sec()
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
s1.Shapes(Picture.Name).OLEFormat.Object.Value = xlOn
End If
Next Picture
MsgBox "İşlem Tamam", vbInformation, " U Y A R I "
End Sub
 
 
Sub hepsini_birak()
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
s1.Shapes(Picture.Name).OLEFormat.Object.Value = xlOff
End If
Next Picture
MsgBox "İşlem Tamam", vbInformation, " U Y A R I "
End Sub

 

[turist]

Makro ile yapılabilir

Kod:

Sub Nesne_ekle()
Dim Picture As Object
Set sh = Sheets(ActiveSheet.Name)
sut3 = "b"
For r = 1 To (sh.Cells(Rows.Count, "a").End(3).Row - 1) * 4 'kisi_sayisi + 1
sol = sh.Cells(r, sut3).Left + son
orta = sh.Cells(r, sut3).Top + 4
gen = 40
yuk = sh.Cells(r, sut3).Height - 4
sh.CheckBoxes.Add(sol, orta, gen, yuk).Characters.Text = ""
Next r
sut = 2
r = 3
son = 0
sat = 2
Set s1 = Sheets(ActiveSheet.Name)
For Each Picture In s1.Shapes
If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object) = "CheckBox" Then
s1.Shapes(Picture.Name).OLEFormat.Object.Top = s1.Cells(sat, sut).Top + 4 ' + say
s1.Shapes(Picture.Name).OLEFormat.Object.Left = s1.Cells(sat, 2).Left + son
s1.Shapes(Picture.Name).OLEFormat.Object.Height = s1.Cells(sat, sut).Height - 8
s1.Shapes(Picture.Name).OLEFormat.Object.Width = 40 's1.Cells(s, sut).Width
s1.Shapes(Picture.Name).OLEFormat.Object.Characters.Text = Cells(1, sut + 1).Value
s1.Shapes(Picture.Name).OLEFormat.Object.Value = xlOff
s1.Shapes(Picture.Name).OLEFormat.Object.LinkedCell = s1.Cells(sat, sut + 1).Address
s1.Shapes(Picture.Name).OLEFormat.Object.Display3DShading = False
sut = sut + 1
son = son + 50
If sut = 6 Then
r = r + 1
sut = 2
son = 0
sat = sat + 1
End If
End If
Next Picture
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
End Sub
 
 
Sub hepsini_sec()
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
s1.Shapes(Picture.Name).OLEFormat.Object.Value = xlOn
End If
Next Picture
MsgBox "İşlem Tamam", vbInformation, " U Y A R I "
End Sub
 
 
Sub hepsini_birak()
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
s1.Shapes(Picture.Name).OLEFormat.Object.Value = xlOff
End If
Next Picture
MsgBox "İşlem Tamam", vbInformation, " U Y A R I "
End Sub

Sayın, halit3.
İstediğimden fazlasını hazırlamışsınız.Mükemmel şekilde de çalışıyor.
Sadece bir konuda tekrar bilginize ve yardımınıza ihtiyacım olacak.
Checkbox'lar "Nesne_ekle" kodu ile yaratılırken, C1, D1, E1, F1 başlıklarından isim alıyorlar.
Bu da 4 checkbox yaratıyor.
Bu sayıyı 2,3,4,5, gibi ; kullanıcının belirleyeceği şekilde nasıl kodlayabiliriz.
Diğer bir ifade ile:
C1, D1, E1, F1,G1,H1 dolu ise ona göre checkbox yaratmak mümkün olabilir mi?

Bilginize ve emeğinize sonsuz saygı ile teşekkür ediyorum, sağolunuz.

 

[halit3]

Sayın, halit3.
İstediğimden fazlasını hazırlamışsınız.Mükemmel şekilde de çalışıyor.
Sadece bir konuda tekrar bilginize ve yardımınıza ihtiyacım olacak.
Checkbox'lar "Nesne_ekle" kodu ile yaratılırken, C1, D1, E1, F1 başlıklarından isim alıyorlar.
Bu da 4 checkbox yaratıyor.
Bu sayıyı 2,3,4,5, gibi ; kullanıcının belirleyeceği şekilde nasıl kodlayabiliriz.
Diğer bir ifade ile:
C1, D1, E1, F1,G1,H1 dolu ise ona göre checkbox yaratmak mümkün olabilir mi?

Bilginize ve emeğinize sonsuz saygı ile teşekkür ediyorum, sağolunuz.

Deneme sayfasında çalıştırılan kod nesneleri guruplandırıyor.

Bu dosya üzerinden gidersek deneme sayfasında örnek olarak söylediklerinizi gösterin bir bakalım.

 

[turist]

Sn.Halit Bey,
Uğraşmış ve farklı çözümler üretmişsiniz. Çok teşekkür ederim.
Ancak; ekli dosyada "deneme" sayfasında da açıkladığım gibi C1, D1, E1, F1 veya G1 hücrelerinin ne kadarı dolu ise (içinde bir veri var ise) o sayıda CheckBox üretilmesi isteğimi ya ben yapamadım ya da kodlarda buna göre bir değerleme yok gibi.

İlginizi eksik etmediğiniz için ve katkılarınız için tekrar içtenlikle teşekkür ederim, sağolunuz.

 

[halit3]

Sn.Halit Bey,
Uğraşmış ve farklı çözümler üretmişsiniz. Çok teşekkür ederim.
Ancak; ekli dosyada "deneme" sayfasında da açıkladığım gibi C1, D1, E1, F1 veya G1 hücrelerinin ne kadarı dolu ise (içinde bir veri var ise) o sayıda CheckBox üretilmesi isteğimi ya ben yapamadım ya da kodlarda buna göre bir değerleme yok gibi.

İlginizi eksik etmediğiniz için ve katkılarınız için tekrar içtenlikle teşekkür ederim, sağolunuz.

Dosyayı inceleyin B sütununa ait genişliğide ekledim sütunda ne kadar başlık varsa o kadar nesne oluşturuyor ve B sütununu ona göre genişletiyor.

 

[halit3]

Bu dosyadaki kodlar birazcık daha kısa

 

[turist]

Bu dosyadaki kodlar birazcık daha kısa

Sn.Halit Bey,
Bu konuda uzmanlığınzı takdirle, çok teşekkür ediyorum.Süper bir çözüm.

Uygulamayı geliştirmek adına yazdığınız "hepsi" macrosuna şöyle bir ekleme yaptım.

Sub hepsi()
[COLOR="Red"]Rows("2:200").Select
    Selection.RowHeight = 35.25
    Range("A1").Select[/COLOR]
Nesneleri_sil2
Nesne_ekle
Nesne_ekle2
Nesne_ekle3
MsgBox "İşlem Tamam", vbInformation, " U Y A R I "
End Sub

Tabii ki, macro bilgim yetersiz olduğundan Kaydet macro ile yaptığımı ekledim.
Satır genişliğini 2 den 200'e değil de; A sütununda yer alan isimlerin 1.cisinden en sonuncusuna kadar nasıl seçtirebilirim.

Zaman ve emek ayırdığınız için, sağolunuz.

 

[halit3]

Sn.Halit Bey,
Bu konuda uzmanlığınzı takdirle, çok teşekkür ediyorum.Süper bir çözüm.

Uygulamayı geliştirmek adına yazdığınız "hepsi" macrosuna şöyle bir ekleme yaptım.

Sub hepsi()
[COLOR=red]Rows("2:200").Select[/COLOR]
[COLOR=red]   Selection.RowHeight = 35.25[/COLOR]
[COLOR=red]   Range("A1").Select[/COLOR]
Nesneleri_sil2
Nesne_ekle
Nesne_ekle2
Nesne_ekle3
MsgBox "İşlem Tamam", vbInformation, " U Y A R I "
End Sub

Tabii ki, macro bilgim yetersiz olduğundan Kaydet macro ile yaptığımı ekledim.
Satır genişliğini 2 den 200'e değil de; A sütununda yer alan isimlerin 1.cisinden en sonuncusuna kadar nasıl seçtirebilirim.

Zaman ve emek ayırdığınız için, sağolunuz.

A sütununun son dolu satırı için

son = Cells(Rows.Count, "a").End(3).Row
Rows("1:" & son).RowHeight = 35.25

Sayfanın son satırı için

Rows("1:" & Rows.Count).RowHeight = 35.25

 

[turist]

Sn.Halit Bey,

Hârika bir çalışma yaptınız.İstediklerimden fazlası oldu.



Foruma ve bize sağladığınız imkanlardan faydalanmakla, bilgi düzeyimizin artmasına , her an yeni şeyler öğrenmemize ve gelişmemize imkan verdiğiniz için, çok teşekkür ederim.

Sağlıkla kalınız.