• DİKKAT

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

Halka çizmek

Aşağıdaki kodları deneyiniz.


Kod: 
Sub cember_Ciz()
t = ActiveCell.Top   'Konum aktif hücrenin
l = ActiveCell.Left  'sol üst kenarı
h = Cells(1, 2).Value  'Çapı
w = h

min_dim = IIf(h > w, w, h)
v_center = t + h / 2 - min_dim / 2
h_center = l + w / 2 - min_dim / 2
    ActiveSheet.Shapes.AddShape(msoShapeOval, h_center, v_center, min_dim, min_dim).Select
    Selection.ShapeRange.Fill.Visible = msoFalse
    With Selection.ShapeRange.Line
    .Visible = msoTrue
    .ForeColor.RGB = RGB(255, 0, 0)
    .Transparency = 0
    End With
    With Selection.ShapeRange.Line
    .Visible = msoTrue
    .Weight = 2.25
    End With
End Sub

Sub cember_sil()
    Selection.ShapeRange.Delete
End Sub
 
Sayın Asri Hocam,
Sanırım B2 ye yazılacak sayıyı çap olarak alıp bir çember çizecek. Bende imleci koyduğum hücrenin sol köşesinde 2 mm çapında bir daire oluşmaya çalışıyor ama oluşamıyor. imleci başka bir yere koyduğunuzda da her şey bitiyor. Hiç bir şey çizilmiyor.
Saygılarımla
 
Tevfik_Kursun' Alıntı:
Sayın Asri Hocam,
Sanırım B2 ye yazılacak sayıyı çap olarak alıp bir çember çizecek. Bende imleci koyduğum hücrenin sol köşesinde 2 mm çapında bir daire oluşmaya çalışıyor ama oluşamıyor. imleci başka bir yere koyduğunuzda da her şey bitiyor. Hiç bir şey çizilmiyor.
Saygılarımla
Genişletmek için tıkla ...

Kodlarda bir sorun yok. B2 ye 200 yazıp, bir hücre seçip, cember_ciz dediğimde kırmızı büyük bir çember çiziyor.

Başka bir bilgisayarda yada yeni bir excel çalışma kitabı açıp deneyebilir misiniz?
 
Sayın asri'nin kodlarında;
B2 ye değil B1 e yazılacak sayı çap olarak algılanıyor. (h = Cells(1, 2).Value 'Çapı)
B1 e çizilecek çemberin çapını yazıyorsunuz, nereye çizilmesini istiyorsanız o hücreyi seçiyorsunuz. Bu şekilde gayet düzgün çalışıyor.

Çap için B1 yerine B2 olarak belirlemek istiyorsanız, kodlarda aşağıdaki değişikliği yapın:
Kod: 
h = Cells([COLOR="Red"][B]2[/B][/COLOR], 2).Value  'Çapı
 
Merhaba,
Her ikinizde haklısınız. Ben B1 e yazıp hücre seçmeden makroyu çalıştırdım o nedenle çemberi görememişim. Her ikinize de çok teşekkür ederim.
Bunu eş merkezli 6 çember haline getirmeyi istiyorum.
Örneğin B1 çemberlerin merkezinin olacağı hücre (AK24 gibi)
B2 ilk çemberin çapı (100 gibi)
B3 çemberlerin çaplarının artma miktarı (200 gibi)
B4 kaç çember çizileceği (5 gibi)
makro çalıştırıldığında hepsini çizecek
Silen makro de kaç çember varsa hepsini silecek
İlgileriniz için tekrar teşekkür ederim
Saygılarımla
 
Makro kodları ile şekil oluşturma ile ilgili daha önce hiç çalışmam olmadı. Ancak çizim ve şekillerin silinmesi durumuyla çok karşılaştım. Bu yüzden silme kodlarını hemen ekliyorum:
Çember, kare, dikdörtgen farketmez, hepsini silsin diyorsanız:
Kod: 
Sub tum_cizimleri_sil()
    ActiveSheet.Shapes.SelectAll
    Selection.Delete
End Sub

Yok, sadece çemberleri silsin, diğerlerini bıraksın istiyorsanız:
Kod: 
Sub sadece_cemberleri_sil()
    For Each nesne In ActiveSheet.Shapes
        If nesne.Name Like "Oval*" Then
            nesne.Delete
        End If
    Next nesne
End Sub
 
Tevfik_Kursun' Alıntı:
Merhaba,
Her ikinizde haklısınız. Ben B1 e yazıp hücre seçmeden makroyu çalıştırdım o nedenle çemberi görememişim. Her ikinize de çok teşekkür ederim.
Bunu eş merkezli 6 çember haline getirmeyi istiyorum.
Örneğin B1 çemberlerin merkezinin olacağı hücre (AK24 gibi)
B2 ilk çemberin çapı (100 gibi)
B3 çemberlerin çaplarının artma miktarı (200 gibi)
B4 kaç çember çizileceği (5 gibi)
makro çalıştırıldığında hepsini çizecek
Silen makro de kaç çember varsa hepsini silecek
İlgileriniz için tekrar teşekkür ederim
Saygılarımla
Genişletmek için tıkla ...

Aşağıdaki kodu deneyiniz.

aşağıdaki değerleri verine güzel bir disk oluşuyor :)
L20
25
6
50



Kod: 
Sub cember_Ciz()
konum = Cells(1, 2).Value
cap = Cells(2, 2).Value
artis = Cells(3, 2).Value
adet = Cells(4, 2).Value


Range(konum).Select
t = ActiveCell.Top   'Konum aktif hücrenin
l = ActiveCell.Left  'sol üst kenarı
For i = 1 To adet
 t = t - (artis / 2)
 l = l - (artis / 2)
 h = h + artis 'Çapı
 w = h

 min_dim = IIf(h > w, w, h)
 v_center = t + h / 2 - min_dim / 2
 h_center = l + w / 2 - min_dim / 2
     ActiveSheet.Shapes.AddShape(msoShapeOval, h_center, v_center, min_dim, min_dim).Select
     Selection.ShapeRange.Fill.Visible = msoFalse
     With Selection.ShapeRange.Line
     .Visible = msoTrue
     .ForeColor.RGB = RGB(255, 0, 0)
     .Transparency = 0
     End With
     With Selection.ShapeRange.Line
     .Visible = msoTrue
     .Weight = 2.25
     End With
 Next i
End Sub

Sub cember_sil()
  Dim shp As Shape
  For Each shp In ActiveSheet.Shapes
    If shp.Type = msoAutoShape Or shp.Type = msoTextBox Then shp.Delete
  Next shp
End Sub
 
Son düzenleme:
Sayın Antonio ve Sayın Asri Beyler,
İlginize çok çok teşekkür ederim. Her ikisinin de harika olduğunu düşünüyorum. Henüz deneyemedim.
Bir şey daha istesem çok mu ayıp etmiş olurum, bilmiyorum.
Bu çemberlerin içine isim yazacağım. İlgili çemberin içi ama bunun içindeki çemberin dışında olduğumu nasıl anlayabilirim?
Saygılarımla
 
Aşğıdaki şekilde deneyiniz.

Kod: 
Sub cember_Ciz()
Call cember_sil
konum = Cells(1, 2).Value
cap = Cells(2, 2).Value
artis = Cells(3, 2).Value
adet = Cells(4, 2).Value
'Renk için
r = Cells(5, 2).Value
g = Cells(6, 2).Value
b = Cells(7, 2).Value


Range(konum).Select
t = ActiveCell.Top   'Konum aktif hücrenin
l = ActiveCell.Left  'sol üst kenarı
For i = 1 To adet
 t = t - (artis / 2)
 l = l - (artis / 2)
 h = h + artis 'Çapı
 w = h

 min_dim = IIf(h > w, w, h)
 v_center = t + h / 2 - min_dim / 2
 h_center = l + w / 2 - min_dim / 2
     ActiveSheet.Shapes.AddShape(msoShapeOval, h_center, v_center, min_dim, min_dim).Select
     Selection.ShapeRange.TextFrame.Characters.Text = "Deneme"
     Selection.ShapeRange.TextFrame.Characters.Font.ColorIndex = 3
     Selection.ShapeRange.Fill.Visible = msoFalse
     With Selection.ShapeRange.Line
     .Visible = msoTrue
     .ForeColor.RGB = RGB(r, g, b)
     .Transparency = 0
     End With
     With Selection.ShapeRange.Line
     .Visible = msoTrue
     .Weight = 2.25
     End With
 Next i
End Sub

Sub cember_sil()
  Dim shp As Shape
  For Each shp In ActiveSheet.Shapes
    If shp.Type = msoAutoShape Or shp.Type = msoTextBox Then shp.Delete
  Next shp
End Sub
 
Sayın Asri Hocam,
Elinize emeğinize sağlık. Öncelikle çok teşekkür ederim.
Burada her çemberin içine yazılacak isimler farklı (1 den çok olabilir). Bu isimleri aynı çemberin içinde farklı noktalara koymak mümkün olabilir mi? Bu çemberin içine konacaklar belli hücrelerden alınabilir mi? Şöyle bir şey de var öğrenci isimleri yerine iki basamaklı öğrenci sırası da yazılabilir (AB, AC, ... ZZ gibi)
Saygılarımla
 
Sayın İdris Hocam,
Burada hedef sosyometri problemini alışkanlıklar doğrultusunda çözmek. Ama projeniz süper. Niye olmasın? Venn Diagramları pek çok öğrencinin korkulu rüyası. Elimdekileri tamamlayayım onu da çalışmalara katabiliiriz.
Saygılarımla
 
Tevfik_Kursun' Alıntı:
Sayın Asri Hocam,
Elinize emeğinize sağlık. Öncelikle çok teşekkür ederim.
Burada her çemberin içine yazılacak isimler farklı (1 den çok olabilir). Bu isimleri aynı çemberin içinde farklı noktalara koymak mümkün olabilir mi? Bu çemberin içine konacaklar belli hücrelerden alınabilir mi? Şöyle bir şey de var öğrenci isimleri yerine iki basamaklı öğrenci sırası da yazılabilir (AB, AC, ... ZZ gibi)
Saygılarımla
Genişletmek için tıkla ...

problemi neden taksit taksit yazıyorsunuz. Tam olarak ne yapmak istediğinizi yazar mısınız.

Bir çember ile başladık sonu yok gibi :)


Çok daha karmaşık problemleri çözüyoruz, bu sorun değil. Ancak aynı konu için sürekli dönüş yapmak yorucu oluyor :)
 
Haklısınız Asri Hocam,
Ama bilgi de bana böyle taksit taksit geldi. Az önce son noktayı koydurabildim ancak.
Ekli dosyada daha önce hazırlanmış bir çalışmanın bir parçası var. Ben bu noktaya kadar geldim. Yazılacak isimleri, kaç çember olması gerektiği, bilginin nasıl alınacağı, nelerin liste haline getirilmesi gerektiği dinamik olarak tamam. Çalışmada ben çember yerine kenarlıklarla sonuçlandırmaya çalışmıştım konuyu. Çember, rehber öğretmenlerinin alışkanlığı imiş ve kimin kimi seçtiği de oklarla birbirini gösterecekmiş. Bu son bilgi bana bugün saat 11:30 gibi söylendi. Ben de o nedenle öğrencileri tam adları ile değil de sıralarıyla oluşturulabilir gibi düşününce (sırayı da iki basamaklı AB, AC, ... gibi) bu ifade ortaya çıktı. İşin sonunda da belki yerleştirilmiş olan sıralar isimlerle değiştirilebilir, diye düşündüm.
Excel dosyada da kimin kimleri istediği liste var.
Sizleri yorduğum ve usandırdığım için özür dilerim. Bu arada RGB yi de ayırmış olmanız muhteşem. Sanırım çemberi elipse çevirmek te değişkene bağlanmış olduğu için İdris Hocanın aklına Venn Şemasını getirdi ve benim de kulağıma kar suyunu kaçırdı.
Sizlerin çalışmalarını gördükçe insanın çalışmaya karşa daha çok iştahı açılıyor. Sitedeki tüm arkadaşlara minnettarım, teşekkür ediyorum.
Saygılarımla
http://s2.dosya.tc/server3/ifte5j/Cember_TK.rar.html
 

Ekli dosyalar

Son düzenleme:
Tevfik_Kursun' Alıntı:
Haklısınız Asri Hocam,
Ama bilgi de bana böyle taksit taksit geldi. Az önce son noktayı koydurabildim ancak.
Ekli dosyada daha önce hazırlanmış bir çalışmanın bir parçası var. Ben bu noktaya kadar geldim. Yazılacak isimleri, kaç çember olması gerektiği, bilginin nasıl alınacağı, nelerin liste haline getirilmesi gerektiği dinamik olarak tamam. Çalışmada ben çember yerine kenarlıklarla sonuçlandırmaya çalışmıştım konuyu. ..l
Genişletmek için tıkla ...

Yani sonuç olarak, isimler var, çemberler var, çemberler iç içe ve isimler bu ilgili çemberlerin içine yazılacak. Konu bu mu?

* Bu şekilde ise, en iç çember belli zaten bunun içindeki hücre adresine ilk isim yazılır.
* ikinci çemberin yeride belli bunun içindeki hücrelerde belli o hücrelere de isimler yazılabilir.

Burada önemli olan çember çapı değiştirilecek mi? İlk hücre değiştirilecek mi? değiştirilece ise neden?
 
Merhaba Asri Hocam,
Hayır aslında merkez ve yarıçaplar değil sadece çizilecek çember sayısı değişebilir. (1 artar yada 1 azalır gibi)
Farklı renkte olmaları daha vurgulu olmasını sağlayabilir. (olmasa da olur)
Bunların dışında dene_TK.xlsx dosyasında gördüğünüz "E sütununda AB kodlu öğrenci sırasıyla AC, AK ve AW kodlu öğrencileri seçmiş" ifadesi de AB den AC ye ok çıkması gibi
Dosyanın revize edilmiş hali ekte
http://s2.dosya.tc/server3/l7s8f4/dene_TK2.rar.html
İlginiz için çok teşekkür ederim.
Saygılarımla
 

Ekli dosyalar

Son düzenleme:
Sayın Asri Hocam,
Bütün gününüzü benim için harcadınız çok teşekkür ederim. Hakkınızı ödeyemem.
Tekrar teşekkür ederim.
Saygılarımla
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst