Excel Forum

Excel Forum (http://www.excel.web.tr/index.php)
-   Makro-VBA (http://www.excel.web.tr/forumdisplay.php?f=48)
-   -   Makro ile hücreye veri girilince arka planı renklendirme (http://www.excel.web.tr/showthread.php?t=168051)

sirkülasyon 10-11-2017 15:01

Makro ile hücreye veri girilince arka planı renklendirme
 
Selamün Aleyküm

Örneğin
H5 hücresine rakam girdiğim zaman
A5:AA5 satırı olduğu gibi arka planı "%15 Koyu Beyaz" olacak şekilde yapmak istiyorum.

Bu makro
A5 :AA150 aralığında bulunan her satır için geçerli olacak şekilde olabilmesi için Makro konusunda rica etsem yardımcı olabilir misiniz?

Teşekkür eder saygılarımı sunarım.

Ömer 10-11-2017 15:19

Merhaba,

Sayfanın kod bölümüne kopyalayıp yapıştırın.

Kod:

Private Sub Worksheet_Change(ByVal Target As Range)

    If Intersect(Target, [H5:H150]) Is Nothing Then Exit Sub
   
    If Target.Count > 1 Then Exit Sub
    With Cells(Target.Row, "A").Resize(1, 27).Interior
        .ColorIndex = xlNone
        If IsNumeric(Target) = True And Target <> "" Then
            .ThemeColor = xlThemeColorDark1
            .TintAndShade = -0.15
        End If
    End With
   
End Sub

.

sirkülasyon 10-11-2017 15:47

Ömer abi
başka sayfada Kod sıkıntısız çalışıyor ancak kendi sayfasına aldığım zaman

Kod:

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Target.Row > 4 And Target.Column = 9 Then
    If Target.Value <> "" Then
        If MsgBox("KDV Eklensin mi?", vbYesNo, "ASKM") = vbYes Then
           
            Target.Offset(0, 1) = Format(WorksheetFunction.Round((Target * 1.08), 2), "#,##0.00")

            Target.Offset(0, 2) = Format(WorksheetFunction.Round((Target.Offset(0, 1) - Target), 2), "#,##0.00")
            Target.Offset(0, 3) = Format(WorksheetFunction.Round((Target.Offset(0, 2) / 2), 2), "#,##0.00")
            Target.Offset(0, 4) = Format(WorksheetFunction.Round((Target), 2), "#,##0.00")
        Else
            Target.Offset(0, 4) = Format(WorksheetFunction.Round((Target), 2), "#,##0.00")
            Target.Offset(0, 1) = ""
            Target.Offset(0, 2) = ""
            Target.Offset(0, 3) = ""
         
        End If
    Else
        Target.Offset(0, 1) = Empty
    End If
End If
End Sub

makrosu var olduğu için

Kod:

Private Sub Worksheet_Change(ByVal Target As Range)

    If Intersect(Target, [H5:H150]) Is Nothing Then Exit Sub
   
    If Target.Count > 1 Then Exit Sub
    With Cells(Target.Row, "A").Resize(1, 27).Interior
        .ColorIndex = xlNone
        If IsNumeric(Target) = True And Target <> "" Then
            .ThemeColor = xlThemeColorDark1
            .TintAndShade = -0.15
        End If
    End With
   
End Sub

kodunu modüle eklediğim de
Kod:

Private Sub Worksheet_Change(ByVal Target As Range)
kısmı hata veriyor bu sebeple makro çalışmıyor.

Allah sizden razı olsun. Özür dileyerek yukarıda yer alan Private Sub Worksheet_Change(ByVal Target As Range) ile başlayan kodları birleştirebilir misiniz?

Ömer 11-11-2017 09:31

Bu şekilde deneyin.

Kod:

Private Sub Worksheet_Change(ByVal Target As Range)

    On Error Resume Next
    If Target.Row > 4 And Target.Column = 9 Then
        If Target.Value <> "" Then
            If MsgBox("KDV Eklensin mi?", vbYesNo, "ASKM") = vbYes Then
               
                Target.Offset(0, 1) = Format(WorksheetFunction.Round((Target * 1.08), 2), "#,##0.00")
   
                Target.Offset(0, 2) = Format(WorksheetFunction.Round((Target.Offset(0, 1) - Target), 2), "#,##0.00")
                Target.Offset(0, 3) = Format(WorksheetFunction.Round((Target.Offset(0, 2) / 2), 2), "#,##0.00")
                Target.Offset(0, 4) = Format(WorksheetFunction.Round((Target), 2), "#,##0.00")
            Else
                Target.Offset(0, 4) = Format(WorksheetFunction.Round((Target), 2), "#,##0.00")
                Target.Offset(0, 1) = ""
                Target.Offset(0, 2) = ""
                Target.Offset(0, 3) = ""
             
            End If
        Else
            Target.Offset(0, 1) = Empty
        End If
    End If
   
    If Target.Row > 4 And Target.Column = 8 Then
        If Target.Count > 1 Then Exit Sub
        With Cells(Target.Row, "A").Resize(1, 27).Interior
            .ColorIndex = xlNone
            If IsNumeric(Target) = True And Target <> "" Then
                .ThemeColor = xlThemeColorDark1
                .TintAndShade = -0.15
            End If
        End With
    End If
   
End Sub

.

sirkülasyon 13-11-2017 06:57

Ömer Abi
Teşekkür Ederim.
Ellerine Sağlık. Hakkını Helal Et.


Saat 02:08

Powered by vBulletin Version 3.7.2
Copyright ©2000 - 2017, Jelsoft Enterprises Ltd.