Değere göre yatay çizgi ekleme.

B

barışD34

Katılım
20 Eylül 2022
Mesajlar
72
Excel Vers. ve Dili
2021 TR
Arkadaşlar selam,

Örnek bir dosya hazırladım.

E sütununda alt alta bir dizi metraj rakamları var.

D64 sütunundan başlayan 8 adet rakam mevcut . Sonrasında artırılabilir , Önemli olan yapılabilir olup olmadığı.

Örnek dosya üzerine açıklama yapıldı fakat ana mantık bu E sütununa makro ile yatay çizgi atılabilir mi?

Normalde sayfaya çizgi ekleyip yatay hale getiriyorum. Çizgiye sağ tıklayınca - Boyut ve Konum- En boy oranını kilitle kısmına tik koyuyorum , bazı durumlarda uzatmak gerekiyor.

Çizgi uzunluğu ayarlanabilir mi hatta böyle bir kod yazılabilir mi bilmiyorum.

Dosyadaki renkler temsili ama bu şekilde bir renk farkı olması gerektiğinden bir şablon hazırladım.

Link:
Metraj.xlsx - 12 KB

İlgilenen arkadaşlara şimdiden teşekkürler.
 
5

52779

Katılım
21 Aralık 2016
Mesajlar
720
Excel Vers. ve Dili
Office 365 TR
Makro ile çözüm konusunda destek olamam..
Koşullu Biçimlendirme ile isterseniz eğer,
(Aslında, dinamik olarak da yapılabilir ama sabit adette veriymiş gibi statik olarak yapıp açıklamayı tercih ettim)

Not : Koşullu Biçimlendirme olunca, çizgi kalınlıkları ince olmakta... Başka seçenek yok...

1 - Önce D64 den itibaren yazılan 8 adet değerin tabloda kaçıncı sıraya denk geldikleri hesaplanır.
Bunun için E64 hücresine
Kod: 
=EĞERHATA(KAÇINCI(D64;$E$8:$E$44;-1);"")
yazılıp 8 satıra kopyalanır. Bu değerler koşullu biçimlendirme formülünde kullanılacak.

2 - Boş bir hücreye kaç sütun için çizgi (alt kenarlık) çizileceğini yazmak uygun olacaktır. Dosyada B7 hücresi bu değer için kullanıldı.
Bu değer maxi 20 kolon ve mini 1 kolon gibi düşünülüp, maxi 20 kolona göre koşullu biçimlendirme aralığı $F$8:$Y$44 olarak seçildi ve biçimlendirmeler bu aralık için yapıldı.

3 - Sırasıyla koşullu biçimlendirme formüllerini yazarsak (Sıra önemli)
Kırmızı Alt Kenarlık için
Kod: 
=VE(SÜTUN()-SÜTUN($F$8)+1<=$B$7;SATIR()-SATIR($F$8)+1=KÜÇÜK($E$64:$E$71;1))
Turuncu Renk Alt Kenarlık için
Kod: 
=VE(SÜTUN()-SÜTUN($F$8)+1<=$B$7;SATIR()-SATIR($F$8)+1=KÜÇÜK($E$64:$E$71;2))
ve Mavi Renkli Alt Kenarlıklar için
Kod: 
=VE(SÜTUN()-SÜTUN($F$8)+1<=$B$7;ESAYIYSA(KAÇINCI(SATIR()-SATIR($F$8)+1;$E$64:$E$71;0)))
Dosyayı ekliyorum... İncelersiniz...
www.filemail.com

Download files - Filemail

Click here to view and download these shared files from Filemail.com
www.filemail.com www.filemail.com
 
B

barışD34

Katılım
20 Eylül 2022
Mesajlar
72
Excel Vers. ve Dili
2021 TR
Öncelikle ilginize teşekkür ederim.
Formül ile koşullu biçim seçenek olarak kullanılabilir neden olmasın , fakat dosya yükü ve boyutu oldukça fazla olduğu için mümkün olduğu kadar makro kullanarak çözüm üretebilmek , hem bu açıdan hem de dinamik veri değişimi olduğu zaman en iyi seçenek olacaktır diye düşünüyorum.

52779' Alıntı:
Makro ile çözüm konusunda destek olamam..
Koşullu Biçimlendirme ile isterseniz eğer,
(Aslında, dinamik olarak da yapılabilir ama sabit adette veriymiş gibi statik olarak yapıp açıklamayı tercih ettim)

Not : Koşullu Biçimlendirme olunca, çizgi kalınlıkları ince olmakta... Başka seçenek yok...

1 - Önce D64 den itibaren yazılan 8 adet değerin tabloda kaçıncı sıraya denk geldikleri hesaplanır.
Bunun için E64 hücresine
Kod: 
=EĞERHATA(KAÇINCI(D64;$E$8:$E$44;-1);"")
yazılıp 8 satıra kopyalanır. Bu değerler koşullu biçimlendirme formülünde kullanılacak.

2 - Boş bir hücreye kaç sütun için çizgi (alt kenarlık) çizileceğini yazmak uygun olacaktır. Dosyada B7 hücresi bu değer için kullanıldı.
Bu değer maxi 20 kolon ve mini 1 kolon gibi düşünülüp, maxi 20 kolona göre koşullu biçimlendirme aralığı $F$8:$Y$44 olarak seçildi ve biçimlendirmeler bu aralık için yapıldı.

3 - Sırasıyla koşullu biçimlendirme formüllerini yazarsak (Sıra önemli)
Kırmızı Alt Kenarlık için
Kod: 
=VE(SÜTUN()-SÜTUN($F$8)+1<=$B$7;SATIR()-SATIR($F$8)+1=KÜÇÜK($E$64:$E$71;1))
Turuncu Renk Alt Kenarlık için
Kod: 
=VE(SÜTUN()-SÜTUN($F$8)+1<=$B$7;SATIR()-SATIR($F$8)+1=KÜÇÜK($E$64:$E$71;2))
ve Mavi Renkli Alt Kenarlıklar için
Kod: 
=VE(SÜTUN()-SÜTUN($F$8)+1<=$B$7;ESAYIYSA(KAÇINCI(SATIR()-SATIR($F$8)+1;$E$64:$E$71;0)))
Dosyayı ekliyorum... İncelersiniz...
www.filemail.com

Download files - Filemail

Click here to view and download these shared files from Filemail.com
www.filemail.com www.filemail.com
Genişletmek için tıkla ...
 
D

DoğanD

Altın Üye
Katılım
22 Eylül 2023
Mesajlar
427
Excel Vers. ve Dili
Office 365 TR
Altın Üyelik Bitiş Tarihi
05-10-2028
Merhaba,

Ben de Macro ile bir çözüm önerebilirim. Açıklamaları kod içine bırakıyorum, kendinize göre revize edersiniz.
Kod: 
Sub Makro2()
On Error GoTo devam
ActiveSheet.DrawingObjects.Delete 'Eski objeleri siler
    Selection.Delete
devam:

Dim i, y, bul As Integer
Dim ara As Double
For i = 64 To 71 'aranan sayı aralığı, artacaksa ona göre ayarlamalısınız.
ara = Cells(i, 4)
    For y = 8 To 44 'bakılacak sayılar aralığı, değişecekse ona göre ayarlamalısınız
    If ara < Cells(y, 5) And ara >= Cells(y + 1, 5) Then
bul = y + 1
GoTo dgr
    End If
    Next y
dgr:
    ActiveSheet.Shapes.AddConnector(msoConnectorStraight, Range("E" & bul).Left, Range("E" & bul).Top, 500, 100).Select '500 rakamı çubuğun uzunluğudur, dilerseniz arttırabilirsiniz.
    With Selection.ShapeRange.Line
        .Visible = msoTrue
        .Weight = 3 'Çubuğun kalınlığı, değiştirebilirsiniz
        .ForeColor.RGB = RGB(WorksheetFunction.RandBetween(1, 255), WorksheetFunction.RandBetween(1, 255), WorksheetFunction.RandBetween(1, 255)) 'her uygulamada rastgele renk olması için RandBetween kullandım, değiştirebilirsiniz.
    End With
   Selection.ShapeRange.ScaleHeight 0, msoFalse, msoScaleFromBottomRight
Next i

End Sub
 
B

barışD34

Katılım
20 Eylül 2022
Mesajlar
72
Excel Vers. ve Dili
2021 TR
DoğanD' Alıntı:
Merhaba,

Ben de Macro ile bir çözüm önerebilirim. Açıklamaları kod içine bırakıyorum, kendinize göre revize edersiniz.
Kod: 
Sub Makro2()
On Error GoTo devam
ActiveSheet.DrawingObjects.Delete 'Eski objeleri siler
    Selection.Delete
devam:

Dim i, y, bul As Integer
Dim ara As Double
For i = 64 To 71 'aranan sayı aralığı, artacaksa ona göre ayarlamalısınız.
ara = Cells(i, 4)
    For y = 8 To 44 'bakılacak sayılar aralığı, değişecekse ona göre ayarlamalısınız
    If ara < Cells(y, 5) And ara >= Cells(y + 1, 5) Then
bul = y + 1
GoTo dgr
    End If
    Next y
dgr:
    ActiveSheet.Shapes.AddConnector(msoConnectorStraight, Range("E" & bul).Left, Range("E" & bul).Top, 500, 100).Select '500 rakamı çubuğun uzunluğudur, dilerseniz arttırabilirsiniz.
    With Selection.ShapeRange.Line
        .Visible = msoTrue
        .Weight = 3 'Çubuğun kalınlığı, değiştirebilirsiniz
        .ForeColor.RGB = RGB(WorksheetFunction.RandBetween(1, 255), WorksheetFunction.RandBetween(1, 255), WorksheetFunction.RandBetween(1, 255)) 'her uygulamada rastgele renk olması için RandBetween kullandım, değiştirebilirsiniz.
    End With
   Selection.ShapeRange.ScaleHeight 0, msoFalse, msoScaleFromBottomRight
Next i

End Sub
Genişletmek için tıkla ...
Öncelikle evet tam böyle olması lazım çok iyi ama extra yardım lazım bi konuda onu yapamadım.

Sayfada başka nesneler de var , başlangıçta diğer nesneleri sildiği için objeleri siliyor doğal olarak.
Diyeceksiniz ki o satırı kaldır ;
Oranlar değiştiğinde yeni orana göre silmeden çiziyor tabi ki ama bu seferde kaldırdığımız satırdan ötürü diğer eski çizgiler de kalmış oluyor.
Yani buton atadım diyelim ; sınır rakamları değişirse , butona tıklandığından eskiler silinsin yeniler orada kalsın , şekline çevirebilir miyiz?
 
dEdE

dEdE

Destek Ekibi
Destek Ekibi
Katılım
1 Temmuz 2005
Mesajlar
2,605
Excel Vers. ve Dili
Ofis 2013 TR 64 Bit
Merhaba,
Çizgi yerine "Alt Kenarlık" kullanılarak yapılmış alternatif çözüm.
Farklı çizgi(Alt Kenarlık) renkleri ve çizgi uzunluğunu belirleme olanağı sağlandı. Örnek dosyanızdaki çizgileri kaldırarak dener misiniz?
C++: 
Sub Test()
    ss1 = Sheets("Metraj hata").Cells(Rows.Count, "D").End(3).Row
    ss2 = Sheets("Metraj hata").Cells(Rows.Count, "E").End(3).Row
    Renk = 3
    
Uz = Application.InputBox("Lütfen çizginin kaç sütun uzunluğunda olacağını yazınız.", "ÇİZGİ UZUNLUĞUNU BELİRLEME")
If Uz = False Then Exit Sub
Range("F3:Z500").Borders.LineStyle = xlLineStyleNone

For i = 64 To ss1
    bul = Cells(i, 4)
        For y = 8 To ss2
            If bul < Cells(y, 5) And bul >= Cells(y + 1, 5) Then Exit For
        Next y
    
    With Range("F" & y, Range("F" & y).Offset(0, Uz - 1)).Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = Renk
        .Weight = xlMedium
    End With
    Renk = Renk + 1
    If Renk > 56 Then Renk = 3
Next i
End Sub
 
Son düzenleme:
D

DoğanD

Altın Üye
Katılım
22 Eylül 2023
Mesajlar
427
Excel Vers. ve Dili
Office 365 TR
Altın Üyelik Bitiş Tarihi
05-10-2028
barışD34' Alıntı:
Öncelikle evet tam böyle olması lazım çok iyi ama extra yardım lazım bi konuda onu yapamadım.

Sayfada başka nesneler de var , başlangıçta diğer nesneleri sildiği için objeleri siliyor doğal olarak.
Diyeceksiniz ki o satırı kaldır ;
Oranlar değiştiğinde yeni orana göre silmeden çiziyor tabi ki ama bu seferde kaldırdığımız satırdan ötürü diğer eski çizgiler de kalmış oluyor.
Yani buton atadım diyelim ; sınır rakamları değişirse , butona tıklandığından eskiler silinsin yeniler orada kalsın , şekline çevirebilir miyiz?
Genişletmek için tıkla ...
Anladığım kadarıyla orijinal dosyanız örnek dosyanızdan çok daha farklı. Daha yakın bir örnek hazırlayıp iletirseniz tekrar bakabilirim. Yada diğer alternatifleri değerlendirebilirsiniz.
 
B

barışD34

Katılım
20 Eylül 2022
Mesajlar
72
Excel Vers. ve Dili
2021 TR
dEdE' Alıntı:
Merhaba,
Çizgi yerine "Alt Kenarlık" kullanılarak yapılmış alternatif çözüm.
Farklı çizgi(Alt Kenarlık) renkleri ve çizgi uzunluğunu belirleme olanağı sağlandı. Örnek dosyanızdaki çizgileri kaldırarak dener misiniz?
C++: 
Sub Test()
    ss1 = Sheets("Metraj hata").Cells(Rows.Count, "D").End(3).Row
    ss2 = Sheets("Metraj hata").Cells(Rows.Count, "E").End(3).Row
    Renk = 3
   
Uz = Application.InputBox("Lütfen çizginin kaç sütun uzunluğunda olacağını yazınız.", "ÇİZGİ UZUNLUĞUNU BELİRLEME")
If Uz = False Then Exit Sub
Range("F3:Z500").Borders.LineStyle = xlLineStyleNone

For i = 64 To ss1
    bul = Cells(i, 4)
        For y = 8 To ss2
            If bul < Cells(y, 5) And bul >= Cells(y + 1, 5) Then Exit For
        Next y
   
    With Range("F" & y, Range("F" & y).Offset(0, Uz - 1)).Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = Renk
        .Weight = xlMedium
    End With
    Renk = Renk + 1
    If Renk > 56 Then Renk = 3
Next i
End Sub
Genişletmek için tıkla ...
Çok teşekkür ederim bu şekilde kullanabilirim.
Sadece bir opsiyon hakkında yardımcı olursanız memnun olurum.
Renk tanımlamasını nasıl yapabiliriz. Bunu kendim ayarlayabilir miyim yani bir olanak var mı?
 
dEdE

dEdE

Destek Ekibi
Destek Ekibi
Katılım
1 Temmuz 2005
Mesajlar
2,605
Excel Vers. ve Dili
Ofis 2013 TR 64 Bit
250550
 
B

barışD34

Katılım
20 Eylül 2022
Mesajlar
72
Excel Vers. ve Dili
2021 TR
DoğanD' Alıntı:
Anladığım kadarıyla orijinal dosyanız örnek dosyanızdan çok daha farklı. Daha yakın bir örnek hazırlayıp iletirseniz tekrar bakabilirim. Yada diğer alternatifleri değerlendirebilirsiniz.
Genişletmek için tıkla ...
Yardımınız için teşekkür ederim.
Aslında söylediğim konu dışında hiçbir fark yok desem doğru olur.
Sadece sol üstte diğer başka makroları çalıştıran butonlar ve kendim makro olmadan yaptığım bazı şekil eklemeleri var.
Dikdörtgen içine alıp görmek ve dikkate alınacak bölgeler gibi. Onlar hala kullanımda.
Bu sebeple çizilen çizgiler butona atandığında eski çizim kaldırılıp yeni varyasyon kalmalı .
Dosyayı ana dosya olarak ekleyemedim boyut olarak sisteme yüklemeyi kabul etmedi sanırım. Yani benim yüklediğim platform.
 
dEdE

dEdE

Destek Ekibi
Destek Ekibi
Katılım
1 Temmuz 2005
Mesajlar
2,605
Excel Vers. ve Dili
Ofis 2013 TR 64 Bit
barışD34' Alıntı:
İşte bu vba renk kodlarını nasıl tanımlayacağımı bilemedim . benim dosyada ilk renk kırmızı , ikinci turuncu , diğerleri de mavi olacak şekilde .
Bunu tek tek mi tanımlıyoruz.
Genişletmek için tıkla ...
Merhaba,
İstediğiniz renkleri yukarıda eklediğim renk tablosundan bulup numaralarını not ediniz. Ben dört renk seçtim, daha fazla ya da az olabilir.
Sonra aşağıdaki kodun R = Array(3, 33, 27, 46) satırına buradaki sayıları silip, istediğiniz renk numaralarını aralarına virgül ekleyerek yazınız.
Yine aşağıdaki kodun If x > 3 Then x = 0 satırındaki 3 sayısını eklediğiniz renk sayısının bir eksiği ile değiştiriniz.(Ör. 6 renk eklemişseniz 5 yazınız)
C++: 
Sub Test_V1()
    ss1 = Sheets("Metraj hata").Cells(Rows.Count, "D").End(3).Row
    ss2 = Sheets("Metraj hata").Cells(Rows.Count, "E").End(3).Row
    R = Array(3, 33, 27, 46)
    x = 0
Uz = Application.InputBox("Lütfen çizginin kaç sütun uzunluğunda olacağını yazınız.", "ÇİZGİ UZUNLUĞUNU BELİRLEME")
If Uz = False Then Exit Sub
Range("F3:Z500").Borders.LineStyle = xlLineStyleNone

For i = 64 To ss1
    bul = Cells(i, 4)
        For y = 8 To ss2
            If bul < Cells(y, 5) And bul >= Cells(y + 1, 5) Then Exit For
        Next y
        
    With Range("F" & y, Range("F" & y).Offset(0, Uz - 1)).Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = R(x)
        .Weight = xlMedium
    End With
    x = x + 1
    If x > 3 Then x = 0
Next i
End Sub
 
B

barışD34

Katılım
20 Eylül 2022
Mesajlar
72
Excel Vers. ve Dili
2021 TR
dEdE' Alıntı:
Merhaba,
İstediğiniz renkleri yukarıda eklediğim renk tablosundan bulup numaralarını not ediniz. Ben dört renk seçtim, daha fazla ya da az olabilir.
Sonra aşağıdaki kodun R = Array(3, 33, 27, 46) satırına buradaki sayıları silip, istediğiniz renk numaralarını aralarına virgül ekleyerek yazınız.
Yine aşağıdaki kodun If x > 3 Then x = 0 satırındaki 3 sayısını eklediğiniz renk sayısının bir eksiği ile değiştiriniz.(Ör. 6 renk eklemişseniz 5 yazınız)
C++: 
Sub Test_V1()
    ss1 = Sheets("Metraj hata").Cells(Rows.Count, "D").End(3).Row
    ss2 = Sheets("Metraj hata").Cells(Rows.Count, "E").End(3).Row
    R = Array(3, 33, 27, 46)
    x = 0
Uz = Application.InputBox("Lütfen çizginin kaç sütun uzunluğunda olacağını yazınız.", "ÇİZGİ UZUNLUĞUNU BELİRLEME")
If Uz = False Then Exit Sub
Range("F3:Z500").Borders.LineStyle = xlLineStyleNone

For i = 64 To ss1
    bul = Cells(i, 4)
        For y = 8 To ss2
            If bul < Cells(y, 5) And bul >= Cells(y + 1, 5) Then Exit For
        Next y
       
    With Range("F" & y, Range("F" & y).Offset(0, Uz - 1)).Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = R(x)
        .Weight = xlMedium
    End With
    x = x + 1
    If x > 3 Then x = 0
Next i
End Sub
Genişletmek için tıkla ...
Çok teşekkür ederim.
Emeğinize sağlık.
Nasıl bir kolaylık sağladı anlatamam.
Tarif ettiğiniz şekilde de düzenlemelerimi uyguladım , çok açık ve net anlatmışsınız bunun için de ayrıca teşekkür ederim.
Çalışmalarınızda başarılar dilerim.
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst