Çarpı vurgusu

[dj_iso06]

Merhaba,

örnek dosyada olduğu gibi indirim gelmiş ürünün ilk fiyatının üzerine otomatik olarak çarpı koymak istiyorum.. Yardımlarınız için şimdiden teşekkür ederim.

 

[hamitcan]

Böyle deneyin.

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column <> 5 Then Exit Sub
   Target.ClearFormats
If Target.Value > 0 Then
   Target.Select
    With Selection.Borders(xlDiagonalDown)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlDiagonalUp)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
Else
End If
End Sub

 

[Korhan Ayhan]

Merhaba,

Alternatif olarak aşağıdaki koduda kullanabilirsiniz.

Option Explicit
 
Sub ÇARPI_VURGUSU()
    Dim X As Byte, Alan As Range, Hücre As Range
    
    Application.ScreenUpdating = False
    
    Set Alan = Range("E4:E" & Cells(Rows.Count, 3).End(3).Row)
    
    For X = 1 To 8
        Alan.Borders(X).LineStyle = xlNone
    Next
    
    For Each Hücre In Alan
        If Hücre.Value > 0 Then
            Hücre.Borders(xlDiagonalDown).LineStyle = 1
            Hücre.Borders(xlDiagonalUp).LineStyle = 1
        End If
    Next
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[dj_iso06]

çok teşekkür ederim üstadlarım.. Allah razı olsun.. iyi çalışmalar..

 

[dj_iso06]

Merhaba,

Alternatif olarak aşağıdaki koduda kullanabilirsiniz.

Option Explicit
 
Sub ÇARPI_VURGUSU()
    Dim X As Byte, Alan As Range, Hücre As Range
    
    Application.ScreenUpdating = False
    
    Set Alan = Range("E4:E" & Cells(Rows.Count, 3).End(3).Row)
    
    For X = 1 To 8
        Alan.Borders(X).LineStyle = xlNone
    Next
    
    For Each Hücre In Alan
        If Hücre.Value > 0 Then
            Hücre.Borders(xlDiagonalDown).LineStyle = 1
            Hücre.Borders(xlDiagonalUp).LineStyle = 1
        End If
    Next
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

peki hocam bu makroyu tek butonla 10 ayrı sayfada işlev gördürebilir miyim?