• DİKKAT

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

Satır veya Sütuna Göre Hücre Biçimlendirme

Katılım
5 Ocak 2009
Mesajlar
1,586
Excel Vers. ve Dili
2003 Türkçe
Selam,
Örnek dosyam ektedir. Açıklama mevcuttur. Yardımcı olabilirseniz çok sevinirim.
İyi çalışmalar.
 

Ekli dosyalar

Merhaba,

Aşağıdaki kodları dener misiniz? 2007 sürümde denendi 2003 sürümünü merak ediyorum.

Kod:
 Sub Kenarlik()
    Dim CizgiKalinligi  As Integer, _
        SonSat          As Long, _
        i               As Long, _
        BasSat          As Long, _
        SonKol          As Integer, _
        DoluAdet        As Integer, _
        Rng             As String
 
    SonSat = Selection.SpecialCells(xlCellTypeLastCell).Row + 1
    SonKol = Range("B5").End(xlToRight).Column
    CizgiKalinligi = 3
    Application.ScreenUpdating = False
    ActiveWindow.DisplayGridlines = False
    Cells.Borders.LineStyle = xlNone
 
    For i = 6 To SonSat
        If Not Cells(i, "B") = "" Then BasSat = i
        DoluAdet = Application.WorksheetFunction.CountA(Range(Cells(i, "B"), Cells(i, SonKol)))
        If DoluAdet > 0 And BasSat = 0 Then BasSat = i
        If DoluAdet = 0 And BasSat > 0 Then
            Rng = Range(Cells(BasSat, "B"), Cells(i - 1, SonKol)).Address
            Cizdir Rng, CizgiKalinligi
            BasSat = 0
        End If
    Next i
    Application.ScreenUpdating = False
    MsgBox "İşlem Tamamdır", vbInformation, "N.YEŞERTENER - [URL="http://www.excel.web.tr/"]www.excel.web.tr[/URL]"
End Sub

Kod:
Sub Cizdir(Adres As String, CizgiKalinligi)
 
    Range(Adres).Borders.Weight = 1
 
    With Range(Adres).Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .Weight = CizgiKalinligi
    End With
    With Range(Adres).Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .Weight = CizgiKalinligi
    End With
    With Range(Adres).Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .Weight = CizgiKalinligi
    End With
    With Range(Adres).Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .Weight = CizgiKalinligi
    End With
End Sub
 

Ekli dosyalar

Selam Hocam
Yardımlarınız için Çok Teşekkür ederim. çok güzel olmuş ancak bir sorun var. birincisi; F15 hücresi dolu olmasına rağmen kenarlık yapmıyor.
ikincisi; bazı verileri değiştirdikten sonra eski kenarlıklar kalıyor.
 
Merhaba,

Hem kodları hem dosyayı yeniledim.

Hücrelerin içi de çizildi. Satır ve Sütuna bağılımlı olmadan tabloyu genişletebilirsiniz.
 
Merhaba,
Necdet üstadın kodları yanında el yapımı gibi olmuş ama alternatif olsun.
Çizim kısmı macro kaydet ile yapılmıştır. iyi çalışmalar.
 

Ekli dosyalar

Güle güle kullanın.

SonSat = Cells.Find(What:="*", After:=[A1], _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
olarak değiştirdim dediğinizi denemiştim ki sizde yanıtınızı değiştirmişsiniz :)

Çünkü F sütununun epey aşağısına yazdığım değeri görmemişti.

Aynı sorun Sayın dentex'in kodlarında da var. aşağılara yazılan değerleri dikkate almıyor.
 
Güle güle kullanın.

SonSat = Cells.Find(What:="*", After:=[A1], _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
olarak değiştirdim dediğinizi denemiştim ki sizde yanıtınızı değiştirmişsiniz :)

Çünkü F sütununun epey aşağısına yazdığım değeri görmemişti.

Aynı sorun Sayın dentex'in kodlarında da var. aşağılara yazılan değerleri dikkate almıyor.

Selam,
+1'i unutmuşum. sizin eklediğiniz gibi sonuna +1 ekleyince çalışıyor.
Kod:
SonSat = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
İyi çalışmalar.
 
Merhaba,
Necdet üstadın kodları yanında el yapımı gibi olmuş ama alternatif olsun.
Çizim kısmı macro kaydet ile yapılmıştır. iyi çalışmalar.

Dentex Hocam Merhabalar,

.TintAndShade = 0
Satırında "Run-time error 438" hatasını veriyor.
Bu satırları siliyorum. Bu sefer "run-time error 1004 Border sınıfının linesytle özelliği kurulamıyor" hatası veriyor.

İlginiz ve yardımlarınız için çok teşekkür ederim.
 
Merhaba Ergün bey,
haklısınız. Ben format kısmını 2010 versiyonda kaydettim. Sanırım 2007'den önce desteklenmiyor. Aşağıdaki satırlar format prosedüründen silinirse sorun kalmaz sanırım. İyi çalışmalar.

Kod:
.TintAndShade = 0
 
Selamlar,

Bende bir örnek dosya hazırladım. Alternatif olarak incelermisiniz.

Uygulanan kod;

Kod:
Option Explicit
 
Sub KENARLIK_ÇİZ()
    Dim X1 As Long, X2 As Integer, X3 As Long, X4 As Integer, Kontrol As Boolean
    Dim Son_Satır As Long, Son_Sütun As Integer, İlk As Long, Son As Long
    Dim Dış_Çizgi_Stili As Variant, Dış_Çizgi_Kalınlığı As Variant
    Dim İç_Çizgi_Stili As Variant, İç_Çizgi_Kalınlığı As Variant
    Dim İlk_Satır As Variant, İlk_Sütun As Variant, Adres As String, Onay As Byte
 
    İlk_Satır = Application.InputBox("Lütfen tablonuzun başlangıç satır değerini giriniz !" _
    & Chr(10) & Chr(10) & "Örnek : 1  gibi")
    If İlk_Satır = "" Or İlk_Satır = False Then
        MsgBox "İşleme devam edebilmek için tablonuzun başlangıç satır değerini girmeniz gerekiyor !", vbCritical
        Exit Sub
    ElseIf Not IsNumeric(İlk_Satır) Then
        MsgBox "Lütfen sayısal değer giriniz !" & Chr(10) & "İşleminiz iptal edilmiştir !", vbCritical, "Hatalı Satır Girişi"
        Exit Sub
    End If
 
    If İlk_Satır <= 0 Or İlk_Satır > Rows.Count Then
        MsgBox "Lütfen 1-" & Rows.Count & " değerleri arasında giriş yapınız !" & Chr(10) & "İşleminiz iptal edilmiştir !", vbCritical, "Hatalı Satır Girişi"
        Exit Sub
    End If
 
 
    İlk_Sütun = Application.InputBox("Lütfen tablonuzun başlangıç sütun değerini giriniz !" _
    & Chr(10) & Chr(10) & "Örnek : A  gibi")
    If İlk_Sütun = "" Or İlk_Sütun = False Then
        MsgBox "İşleme devam edebilmek için tablonuzun başlangıç sütun değerini girmeniz gerekiyor !", vbCritical
        Exit Sub
    ElseIf IsNumeric(İlk_Sütun) Then
        MsgBox "Lütfen metinsel değer giriniz !" & Chr(10) & "İşleminiz iptal edilmiştir !", vbCritical, "Hatalı Sütun Girişi"
        Exit Sub
    End If
 
    If Columns.Count = 256 Then
        If İlk_Sütun < "A" Or İlk_Sütun > "IV" Then
            MsgBox İlk_Sütun & " bu isimde bir sütun yok !" & Chr(10) & Chr(10) & "Lütfen A-IV" & " değerleri arasında giriş yapınız !" & Chr(10) & "İşleminiz iptal edilmiştir !", vbCritical, "Hatalı Sütun Girişi"
            Exit Sub
        End If
    End If
 
    If Columns.Count = 16384 Then
        If İlk_Sütun < "A" Or İlk_Sütun > "IV" Then
            MsgBox İlk_Sütun & " bu isimde bir sütun yok !" & Chr(10) & Chr(10) & "Lütfen A-XFD" & " değerleri arasında giriş yapınız !" & Chr(10) & "İşleminiz iptal edilmiştir !", vbCritical, "Hatalı Sütun Girişi"
            Exit Sub
        End If
    End If
 
    If Cells(1, İlk_Sütun).Column <= 0 Or Cells(1, İlk_Sütun).Column > Columns.Count Then
        MsgBox "Lütfen 1-" & Columns.Count & " değerleri arasında giriş yapınız !" & Chr(10) & "İşleminiz iptal edilmiştir !", vbCritical, "Hatalı Sütun Girişi"
        Exit Sub
    End If
 
 
    Dış_Çizgi_Stili = Application.InputBox("Lütfen uygulamak istediğiniz dış çizgi stili değerini giriniz !" _
    & Chr(10) & Chr(10) & "1-13 arası bir değer giriniz !", , 3)
    If Dış_Çizgi_Stili = "" Or Dış_Çizgi_Stili = False Then
        MsgBox "İşleme devam edebilmek için uygulamak istediğiniz dış çizgi stili değerini girmeniz gerekiyor !", vbCritical
        Exit Sub
    ElseIf Not IsNumeric(Dış_Çizgi_Stili) Then
        MsgBox "Lütfen sayısal değer giriniz !" & Chr(10) & "İşleminiz iptal edilmiştir !", vbCritical, "Hatalı Dış Çizgi Stili Girişi"
        Exit Sub
    ElseIf Dış_Çizgi_Stili < 1 Or Dış_Çizgi_Stili > 13 Then
        MsgBox "Lütfen 1-13 arası bir değer giriniz !" & Chr(10) & "İşleminiz iptal edilmiştir !", vbCritical, "Hatalı Dış Çizgi Stili Girişi"
        Exit Sub
    End If
 
 
    Dış_Çizgi_Kalınlığı = Application.InputBox("Lütfen uygulamak istediğiniz dış çizgi kalınlık değerini giriniz !" _
    & Chr(10) & Chr(10) & "1-3 arası bir değer giriniz !", , 3)
    If Dış_Çizgi_Kalınlığı = "" Or Dış_Çizgi_Kalınlığı = False Then
        MsgBox "İşleme devam edebilmek için uygulamak istediğiniz dış çizgi kalınlık değerini girmeniz gerekiyor !", vbCritical
        Exit Sub
    ElseIf Not IsNumeric(Dış_Çizgi_Kalınlığı) Then
        MsgBox "Lütfen sayısal değer giriniz !" & Chr(10) & "İşleminiz iptal edilmiştir !", vbCritical, "Hatalı Dış Çizgi Kalınlığı Girişi"
        Exit Sub
    ElseIf Dış_Çizgi_Kalınlığı < 1 Or Dış_Çizgi_Kalınlığı > 3 Then
        MsgBox "Lütfen 1-3 arası bir değer giriniz !" & Chr(10) & "İşleminiz iptal edilmiştir !", vbCritical, "Hatalı Dış Çizgi Kalınlığı Girişi"
        Exit Sub
    End If
 
 
    İç_Çizgi_Stili = Application.InputBox("Lütfen uygulamak istediğiniz iç çizgi stili değerini giriniz !" _
    & Chr(10) & Chr(10) & "1-13 arası bir değer giriniz !", , 8)
    If İç_Çizgi_Stili = "" Or İç_Çizgi_Stili = False Then
        MsgBox "İşleme devam edebilmek için uygulamak istediğiniz iç çizgi stili değerini girmeniz gerekiyor !", vbCritical
        Exit Sub
    ElseIf Not IsNumeric(İç_Çizgi_Stili) Then
        MsgBox "Lütfen sayısal değer giriniz !" & Chr(10) & "İşleminiz iptal edilmiştir !", vbCritical, "Hatalı İç Çizgi Stili Girişi"
        Exit Sub
    ElseIf İç_Çizgi_Stili < 1 Or İç_Çizgi_Stili > 13 Then
        MsgBox "Lütfen 1-13 arası bir değer giriniz !" & Chr(10) & "İşleminiz iptal edilmiştir !", vbCritical, "Hatalı İç Çizgi Stili Girişi"
        Exit Sub
    End If
 
 
    İç_Çizgi_Kalınlığı = Application.InputBox("Lütfen uygulamak istediğiniz iç çizgi kalınlık değerini giriniz !" _
    & Chr(10) & Chr(10) & "1-3 arası bir değer giriniz !", , 3)
    If İç_Çizgi_Kalınlığı = "" Or İç_Çizgi_Kalınlığı = False Then
        MsgBox "İşleme devam edebilmek için uygulamak istediğiniz iç çizgi kalınlık değerini girmeniz gerekiyor !", vbCritical
        Exit Sub
    ElseIf Not IsNumeric(İç_Çizgi_Kalınlığı) Then
        MsgBox "Lütfen sayısal değer giriniz !" & Chr(10) & "İşleminiz iptal edilmiştir !", vbCritical, "Hatalı İç Çizgi Kalınlığı Girişi"
        Exit Sub
    ElseIf İç_Çizgi_Kalınlığı < 1 Or İç_Çizgi_Kalınlığı > 3 Then
        MsgBox "Lütfen 1-3 arası bir değer giriniz !" & Chr(10) & "İşleminiz iptal edilmiştir !", vbCritical, "Hatalı İç Çizgi Kalınlığı Girişi"
        Exit Sub
    End If
 
 
 
    Application.ScreenUpdating = False
 
    If WorksheetFunction.CountA(Cells) > 0 Then
        Son_Satır = Cells.Find(What:="*", After:=Range("A1"), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    End If
 
    If WorksheetFunction.CountA(Cells) > 0 Then
        Son_Sütun = Cells.Find(What:="*", After:=Range("A1"), SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
    End If
 
    Adres = Cells(İlk_Satır, İlk_Sütun).Address & ":" & Cells(Son_Satır, Son_Sütun).Address
 
    Onay = MsgBox(Adres & " hücrelerinin kenarlıklarını değiştirmek istiyor musunuz?", vbCritical + vbYesNo, "Dikkat !")
 
    If Onay = vbNo Then
        MsgBox "İşleminiz iptal edilmiştir.", vbInformation
        Exit Sub
    End If
 
 
    Range(Adres).Borders.LineStyle = xlNone
 
        For X1 = İlk_Satır To Son_Satır
            For X2 = Cells(1, İlk_Sütun).Column To Son_Sütun
                If Cells(X1, X2) <> "" Then
                    İlk = X1
                    GoTo Devam1
                End If
            Next
 
            If İlk = 0 Then GoTo Yeniden
Devam1:
 
            For X3 = X1 + 1 To Son_Satır
                If Kontrol = True Then GoTo Devam3
                For X4 = Cells(1, İlk_Sütun).Column To Son_Sütun
                    If Cells(X3, X4) <> "" Then
                        Son = X3
                        Kontrol = False
                        GoTo Devam2
                    End If
                    Kontrol = True
                Next
Devam2:
            Next
 
Devam3:
            If Son = 0 Then
                Son = İlk
            End If
 
            With Range(Cells(İlk, İlk_Sütun), Cells(Son, Son_Sütun).Address)
                .Borders(xlEdgeLeft).LineStyle = Val(Dış_Çizgi_Stili)
                .Borders(xlEdgeLeft).Weight = Val(Dış_Çizgi_Kalınlığı)
                .Borders(xlEdgeRight).LineStyle = Val(Dış_Çizgi_Stili)
                .Borders(xlEdgeRight).Weight = Val(Dış_Çizgi_Kalınlığı)
                .Borders(xlEdgeBottom).LineStyle = Val(Dış_Çizgi_Stili)
                .Borders(xlEdgeBottom).Weight = Val(Dış_Çizgi_Kalınlığı)
                .Borders(xlEdgeTop).LineStyle = Val(Dış_Çizgi_Stili)
                .Borders(xlEdgeTop).Weight = Val(Dış_Çizgi_Kalınlığı)
                 If (Son - İlk) >= 1 Then
                    .Borders(xlInsideHorizontal).LineStyle = Val(İç_Çizgi_Stili)
                    .Borders(xlInsideHorizontal).Weight = Val(İç_Çizgi_Kalınlığı)
                 End If
                 If (Son_Sütun - 2) >= 1 Then
                    .Borders(xlInsideVertical).LineStyle = Val(İç_Çizgi_Stili)
                    .Borders(xlInsideVertical).Weight = Val(İç_Çizgi_Kalınlığı)
                 End If
            End With
 
            X1 = Son
            İlk = 0
            Son = 0
            Kontrol = False
Yeniden:
        Next
 
    Application.ScreenUpdating = True
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation, "[URL="http://www.excel.web.tr"]www.excel.web.tr[/URL]"
End Sub
 

Ekli dosyalar

Selamlar,

Bende bir örnek dosya hazırladım. Alternatif olarak incelermisiniz.

Selam Hocam,
Öncelikle yardımlarınız ve ilginiz için çok teşekkür ederim.
Dosyanızı kullanamadım. satır için 6, sütun için B giriyorum.
"Lütfen 1-256 değerleri arasında giriş yapınız !" diyor.
bu sefer sütun için 2 giriyorum. bu sefer de "Lütfen metinsel değer giriniz !" diyor.
 
Merhaba Ergün bey,
haklısınız. Ben format kısmını 2010 versiyonda kaydettim. Sanırım 2007'den önce desteklenmiyor. Aşağıdaki satırlar format prosedüründen silinirse sorun kalmaz sanırım. İyi çalışmalar.

Kod:
.TintAndShade = 0

Selam,
Bu seferde "run-time error 1004 Border sınıfının linesytle özelliği kurulamıyor" hatası veriyor.

Kodlarınızda aşağıda kırmızı alanlarda görüldüğü gibi eklemeler ve değişiklikler yaptım. Gayet iyi çalışıyor. ellerinize sağlık çok teşekkür ederim.
İyi çalışmlar.
Kod:
Sub bicimle()
Dim sh As Worksheet
Dim CizgiKalinligi As Integer
Dim Rng As String
Set sh = Sheets("Sayfa1")
[COLOR="Red"]CizgiKalinligi = 3[/COLOR]
[COLOR="Red"]sn = sh.Range("B5:F65536").Find(What:="*", After:=Range("B5"), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

 sh.Range("B6:F65536").Borders.LineStyle = xlNone[/COLOR]
        For i = 6 To sn
         t = 0
        For j = 1 To 5
          If IsEmpty(sh.Cells(i, 1 + j)) = False Then t = t + 1 'dolu hücreler için
        Next j
          If t >= 1 Then w = w + 1 'her dolu satırda
          If t = 0 And w > 0 Then 'boş satıra geldiğinde
           [COLOR="red"]Rng = sh.Range("b" & i - (w) & ":f" & i - 1).Address
           Cizdir1 Rng, CizgiKalinligi[/COLOR]
          w = 0
          End If
          If i = sn Then  'son satıra geldiğinde
         [COLOR="red"]  Rng = sh.Range("b" & i - (w - 1) & ":f" & i).Address
            Cizdir1 Rng, CizgiKalinligi[/COLOR]
          w = 0
          End If
     Next i
Set sh = Nothing
End Sub
[COLOR="red"]Sub Cizdir1(Adres As String, CizgiKalinligi)
    
    Range(Adres).Borders.Weight = 1
    
    With Range(Adres).Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .Weight = CizgiKalinligi
    End With
    With Range(Adres).Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .Weight = CizgiKalinligi
    End With
    With Range(Adres).Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .Weight = CizgiKalinligi
    End With
    With Range(Adres).Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .Weight = CizgiKalinligi
    End With

End Sub
Sub Cizdir2(Adres As String, CizgiKalinligi)
  
    Range(Adres).Borders.Weight = 1
    
End Sub[/COLOR]
 
Merhaba,
bu şekilde yeni ve daha optimal yollar öğrenebiliyoruz. İyi çalışmalar.
 
Selamlar,

Ergün bey iş çıkışında dosyayı ve kodları biraz aceleyle foruma eklemiştim. Tüm kontrolleri yapamamıştım. Şimdi sanıyorum tüm kontrolleri sağladım.

2003 ve üzeri versiyonlarda sorun çıkarmadan çalışması gerekiyor.

Üstteki mesajımdaki kodu ve dosyayı güncelledim. İncelermisiniz.
 
Selamlar,

Ergün bey iş çıkışında dosyayı ve kodları biraz aceleyle foruma eklemiştim. Tüm kontrolleri yapamamıştım. Şimdi sanıyorum tüm kontrolleri sağladım.

2003 ve üzeri versiyonlarda sorun çıkarmadan çalışması gerekiyor.

Üstteki mesajımdaki kodu ve dosyayı güncelledim. İncelermisiniz.

Selam Hocam,
Gerçekten çok harika olmuş. Çok zahmet etmişsiniz. ellerinize sağlık.
İyi çalışmalar.
 
Selam Necdet Hocam,
sizin kodladığınız Sub Cizdir'i Public Sub Cizdir olarak yapacağım. bu yüzden birkaç şey sormak istiyorum.
Rng = Range(Cells(BasSat, "B"), Cells(i - 1, SonKol)).Address

örneğin yukarıdaki kod'un sonucu $B$6:$F$30 olarak okunuyor bunu nasıl Sayfa1!$B$6:$F$30 okuyabiliriz? Kısa bir yolu var mıdır?
İyi çalışmalar.
 
Selam Necdet Hocam,
sizin kodladığınız Sub Cizdir'i Public Sub Cizdir olarak yapacağım. bu yüzden birkaç şey sormak istiyorum.


örneğin yukarıdaki kod'un sonucu $B$6:$F$30 olarak okunuyor bunu nasıl Sayfa1!$B$6:$F$30 okuyabiliriz? Kısa bir yolu var mıdır?
İyi çalışmalar.

aşağıdaki gibi deneyebilirsiniz de, amaç ne onu anlamadım.


Kod:
Rng = "Sayfa1!" & Range(Cells(BasSat, "B"), Cells(i - 1, SonKol)).Address
 
Selamlar,

Kodlarda küçük hatalar tesbit ettim. Üstteki mesajımdaki dosyayı ve kodları yeniden güncelledim. İncelermisiniz.
 
Selamlar,

Kodlarda küçük hatalar tesbit ettim. Üstteki mesajımdaki dosyayı ve kodları yeniden güncelledim. İncelermisiniz.

Selam Korhan Hocam,
Biraz geç farkettim özür dilerim. Emeğiniz ve yardımlarınız için çok teşekkür ederim. Çok güzel bir çalışma olmuş ellerinize sağlık.
İyi çalışmalar.
 
Geri
Üst