hücreleri çizgi ile bağlamak

[peleryn]

Herkese Merhabalar;

Makrolar,çizim araç çubuğundaki çizgi aracı ve hücrelerin seçilebilmesi...Üçü de excelin bir elemanı olduğuna göre istediğim yapılabilir diye düşünüyorum ama nasıl olur kolay mıdır zor mudur kestiremedim..

İhtiyacım olan şey şu:Varsayalım ki şu an F6 hücresi seçili olsun misal ben K9 u seçtiğimde F6 ile K9 arasındaki en kısa yolu seçen kırmızı bir doğru çizgi bu iki hücre arasına yerleşsin.K9 dan sonra diyelim G 14 seçilmişse doğru çizgi K9 ve G14 aralığında olacak..

Ve bu makro F6:L15 aralığında çalışacak...

İlgilenecek olanlara şimdiden teşekkür ederim.

Ekteki örnek dosyanın kodları Evren Gizlen Hocamızın hazırladığı kodlardır.

 

[peleryn]

Arkadaşlar engelli çocuklarla çalışıyorum Evren Bey sağolsun seçili hücreleri renklendirme ile ilgili şeklini yaptı ama bu şekilde addline özelliği ile çalışacak hali daha verimli olacak misal tablo a da 4x3 olarak verilen sonucu çift tıklandığında tablo b de 12 olarak seçilecek ama bu ikisi arasına bir çizgi çekme şansım olursa çocuğun bağlantıyı kurması daha da kolaylaşacak.Yardımlarınızı bekliyorum..

 

[peleryn]

Ekli örnek dosyayı 1.mesajda değişiklikleriyle beraber güncelledim.Karışıklık olmasın diye ismini burada belirtiyorum güncel son dosyanın adı "koprucizgi(2).xls" tir.Daha önceki dosya üzerinde çalışmaya devam eden varsa cevabı elbetteki kabulümdür ve benim için yeterli olacaktır.

İlgilenecek herkese şimdiden teşekkür ederim.

 

[peleryn]

Bayram sonrası soruyu gören kişilerin sayısının artacağını umarak bir defalığına konuyu özellikle yukarı taşımak için bu mesajı yazıyorum.Bu durumdan rahatsız olanlar olursa aflarına sığınıyorum.

Sayfa içinde selection change olayı ile seçimden önceki son hücre ile seçilen hücre arasına bir çizgi koyan bir kod lazım forumda arama yapınca benzer birşey bulamadım.Link öneren olursa ona da sevinirim.

Herkese iyi çalışmalar dilerim.

 

[peleryn]

Arkadaşlar ;

Elimden geleni yaptım ve bence çok birşey kalmadı usta bir el kalan bir iki soruna el atınca hallolacak bence.Ekli dosyada selectionchange olayında addline makrosu devreye giriyor ve "start" olarak adlandırılan hücre ile "stop" olarak adlandırılan hücre arasında bir çizgi çiziyor.


Şu durumda yeni bir hücre seçtiğimde;

1.Adım:sayfadaki çizgilerin silinmesi
2.Adım:stop adlı hücrenin "start" adını alması ve yeni seçilen hücrenin "stop" adını alması
ve hazır olan addline makrosunun çalışması kaldı.

 

[Korhan Ayhan]

Selamlar,

Sayfa1 in kod bölümündeki kodları aşağıdaki şekilde değiştirip denermisiniz.

Private Sub Worksheet_Activate()
    ActiveWorkbook.Names.Add Name:="start", RefersTo:=Selection
End Sub
 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    On Error Resume Next
    ActiveSheet.DrawingObjects.Delete
    On Error GoTo 0
    ActiveWorkbook.Names.Add Name:="stop", RefersTo:=Selection
    Call AddLine
    ActiveWorkbook.Names.Add Name:="start", RefersTo:=Selection
End Sub

 

[peleryn]

Korhan Hocam çok teşekkür ederim.Hemen hemen nihayete erdim sayılır.Düzeltmenizle sonunda hücreler arasında istediğim gibi dolaşan bir ok oluşturdum.Şimdi bu dosyada oluşan mantığı F6:L15 aralığında çalışacak şekilde yerleştirmeme yardımcı olan olursa sorunum hallolmuş olacak ilginiz ve yardımınız için çok teşekkür ederim hocam.

 

[Skorpiyon]

Sayın peleryn,

Sayın Korhan Hocam'ın kodlarına aşağıdaki satırı ekleyerek deneyiniz.

Sayfa1 kodları;

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error Resume Next
If Intersect(Target, Range("F6:L15")).Address <> ActiveCell.Address Then Exit Sub
ActiveSheet.DrawingObjects.Delete
On Error GoTo 0
ActiveWorkbook.Names.Add Name:="stop", RefersTo:=Selection
Call AddLine
ActiveWorkbook.Names.Add Name:="start", RefersTo:=Selection
End Sub

 

[peleryn]

Şaban Hocam çok teşekkür ederim sizin ve Korhan Hocamın destekleriyle neredeyse son haline ulaştım.Sadece sayfaya bir buton yerleştirmişsem o butonu silmeyecek şekilde drawingobjects.delete kodlarının düzenlenmesi kaldı.(Bir buton yerleştirilecek ve "rastgele" makrosu bu butona atanacak..)

Dosyanın son halini ekte veriyorum.Herkese incelemesini tavsiye ederim bence hoş bir çalışma oldu..(Dosyada ağırlıklı olarak Evren hocamın ve destekleriyle Necdet,Korhan ve Şaban hocamın emekleri vardır.Kendilerine tekrar teşekkür ediyorum.)

 

[peleryn]

Arkadaşlar Korhan hocanın yardımlarıyla konu çözülmüştür.İlgilenecek olanlar için dosyanın son halini ek'te veriyorum.

 

[Orion1]

Sayın Peleryn;
İstediğiniz sonunda elde ettiniz.Tebrik ederim.
Güle güle kullanın.

 

[1Al2Ver]

Arkadaşlar Korhan hocanın yardımlarıyla konu çözülmüştür.İlgilenecek olanlar için dosyanın son halini ek'te veriyorum.

Sayın peleryn merhaba,

Paylaşım için teşekkür ederim,

Saygılarımla.

 

[peleryn]

Sayın Peleryn;
İstediğiniz sonunda elde ettiniz.Tebrik ederim.
Güle güle kullanın.

Evren Hocam azmin zaferi oldu valla Siz olmasanız zaten bu son halini hayal bile edemeyecektim teşekkür ederim..

Sayın peleryn merhaba,

Paylaşım için teşekkür ederim,

Saygılarımla.

Sn 1Al2Ver rica ederim..

 

[uzmanamele]

merhaba
arkadaşların düzenlediği kodlara küçük bir katkıdada ben bulunayım.

Sub AddLine()
Sheets("Sayfa1").Select
Dim l1 As Long, l2 As Long, r1 As Long, r2 As Long

l1 = Range("Start").Left + Range("Start").Width / 2
l2 = Range("Start").Top + Range("Start").Height / 2
r1 = Range("Stop").Left + Range("Stop").Width / 2
r2 = Range("Stop").Top + Range("Stop").Height / 2
With ActiveSheet.Shapes.AddLine(l1, l2, r1, r2).Line
    .ForeColor.RGB = RGB(255, 0, 0)
    .BeginArrowheadStyle = msoArrowheadTriangle
    .EndArrowheadStyle = msoArrowheadTriangle
End With
End Sub

 

[peleryn]

merhaba
arkadaşların düzenlediği kodlara küçük bir katkıdada ben bulunayım.

Sub AddLine()
Sheets("Sayfa1").Select
Dim l1 As Long, l2 As Long, r1 As Long, r2 As Long

l1 = Range("Start").Left + Range("Start").Width / 2
l2 = Range("Start").Top + Range("Start").Height / 2
r1 = Range("Stop").Left + Range("Stop").Width / 2
r2 = Range("Stop").Top + Range("Stop").Height / 2
With ActiveSheet.Shapes.AddLine(l1, l2, r1, r2).Line
    .ForeColor.RGB = RGB(255, 0, 0)
    [COLOR="Red"].BeginArrowheadStyle = msoArrowheadTriangle
    .EndArrowheadStyle = msoArrowheadTriangle[/COLOR]
End With
End Sub

Hocam ilginiz için teşekkür ederim.