Seçili Hücreye Üst Kenarlık Çizgisi

[ahmedummu]

Merhaba arkadaşlar.

A sütunundan J sütununa kadar seçim yapıyorum ve bu hücrelere üst kenarlık çizmek istiyorum. Aşağıdaki gibi denedim ama olmadı. Yardımcı olabilir misiniz.

Selection.Borders = xlEdgeTop

 

[ahmedummu]

Çözüldü.

 

[muratboz06]

Belki başkasına faydası olur.

Sub UstCizgiCiz()
    Dim rng         As Range
    
    For Each rng In Selection
        rng.Select
        With Selection.Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
    Next rng
    
End Sub

 

[ahmedummu]

Belki başkasına faydası olur.

Sub UstCizgiCiz()
    Dim rng         As Range
   
    For Each rng In Selection
        rng.Select
        With Selection.Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
    Next rng
   
End Sub

Teşekkürler Murat bey. Benim bulduğum çözüm daha uzundu.

Peki aşağıdaki kodların daha kısa olanı için yardımcı olur musunuz. A sütunu seçili iken, seçili satı, iki üst ve iki alt satırlar olmak üzere, A sütununun Sol, J sütununun sağ kenarlıklarnın çizimi.

With Range("A" & ActiveCell.Row - 2).Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With

With Range("A" & ActiveCell.Row - 1).Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With

With Range("A" & ActiveCell.Row).Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With

With Range("A" & ActiveCell.Row + 1).Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With

With Range("A" & ActiveCell.Row + 2).Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
'---------------------------------------------------------------------------------------------------------
With Range("j" & ActiveCell.Row - 2).Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With

With Range("j" & ActiveCell.Row - 1).Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With

With Range("j" & ActiveCell.Row).Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With

With Range("j" & ActiveCell.Row + 1).Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With

With Range("j" & ActiveCell.Row + 2).Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With

 

[Korhan Ayhan]

Alternatif;

Option Explicit

Sub Ust_Kenarlik_Ekle()
    Dim X As Byte
    
    With Selection
        For X = 5 To 12
            .Borders(X).LineStyle = xlNone
        Next
    
        .Borders(8).LineStyle = xlContinuous
        .Borders(12).LineStyle = xlContinuous
    End With
    
    MsgBox "Seçili alana üst kenarlık eklenmiştir.", vbInformation
End Sub