Tabloda Tıklanan Sayıların Renklenmesi

[1Al2Ver]

Merhaba,

1) "B2:I11" arasında tıklanan hücrelerin zemin renginin SARI olmasını ve renklenen verilerin, "B13:K13" arasına aktarılmasını,

2) Tablo silinene kadar renklenen verilerin, örnek tablodaki gibi kalmasını, arzuluyorum.

Gerekli kod'u rica ediyorum.

Teşekkür ederim.

 

[AdemCan]

Merhaba örnek kod.
Not : Range("B13:K13").ClearContents satırını Range("B13:K13").Clear olarak değiştiriniz.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Column > 1 And Target.Column < 10 And Target.Row > 1 And Target.Row < 12 Then
        Target.Interior.Color = vbYellow
        Target.Font.Bold = True
    End If
End Sub

Sub aktar()
Application.ScreenUpdating = False
    Dim h As Range, r As Byte
    r = 2
        For Each h In Range("B2:I11")
            If h.Interior.Color = vbYellow Then
                h.Copy Cells(13, r)
                r = r + 1
            End If
        Next h
Application.ScreenUpdating = True
End Sub

 

[1Al2Ver]

Sayın AdemCan merhaba,

İlginiz ve çözüm için çok teşekkür ederim,

Sevgi ve saygılarımla.

 

[AdemCan]

Rica ederim, saygılar.

 

[1Al2Ver]

Sayın AdemCan, tekrar merhaba,

Aktar kodu'nun şöyle çalışmasını arzuluyorum,

For Each h In Range("B2:I11") aralığı yerine "B2:B200" aralığı

h.Copy Cells(13, r) yerine 4.sütun olan "D" sütunu 2 nci hücreden itibaren kopyalansın,

Aşağıdaki gibi denedim ama 400 hatası verdi, belli ki uyuşmazlık var,

Sub aktar()
Application.ScreenUpdating = False
Dim h As Range, r As Byte
r = 4
For Each h In Range("B2:B200")
If h.Interior.Color = vbYellow Then
'h.Copy Cells(2, r)
h.Copy Columns(4, r)
r = r + 1
End If
Next h
Application.ScreenUpdating = True
End Sub

Teşekkür ederim.

 

[AdemCan]

Merhaba, tüm kodları değiştiriniz.

Sub SİL()
    If (MsgBox("İlgili Kayıtları Silmek İstiyormusunuz?", vbCritical + vbDefaultButton1 + vbYesNo, "UYARI")) = vbYes Then
        c = Cells(2, Columns.Count).End(1).Column
            If c > 2 Then
                Cells(2, "D").Resize(1, c).Clear
        '        Range("B13:K13").ClearContents '( Hem veriyi hem renkleri siler )
                Range("B2:B200").Interior.ColorIndex = xlNone '(Sadece renkli hücrenin zemin rengini siler, veriler kalır)
                Range("B2:B200").Font.Bold = False
            Else
                MsgBox "Temizlenecek kayıt bulunamadı", vbInformation, ""
            End If
    End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Column = 2 And Target.Row > 1 And Target.Row < 200 Then
        Target.Interior.Color = vbYellow
        Target.Font.Bold = True
    End If
End Sub

Sub aktar()
Application.ScreenUpdating = False
    Dim h As Range, r As Byte
    r = 4
        For Each h In Range("B2:B200")
            If h.Interior.Color = vbYellow Then
                h.Copy Cells(2, r)
                r = r + 1
            End If
        Next h
Application.ScreenUpdating = True
End Sub

 

[1Al2Ver]

Sayın AdemCan merhaba,

Sanırım ben eksik yada yanlış ifade de bulundum,

Seçimden sonra kopyalanacak olan alan D2 : D100, diğer bir deyimle "D" sütunu olacak,

Zahmet olmaz ise kodu böyle revize ederseniz memnun olurum,

Teşekkür ederim.

 

[AdemCan]

D sütununa sıralaması için, tüm kodları değiştiriniz.

Sub SİL()
    If (MsgBox("İlgili Kayıtları Silmek İstiyormusunuz?", vbCritical + vbDefaultButton1 + vbYesNo, "UYARI")) = vbYes Then
        c = Cells(Rows.Count, 4).End(3).Row
            If c >= 2 Then
                Range("D2:D" & c).Clear
        '        Range("B13:K13").ClearContents '( Hem veriyi hem renkleri siler )
                Range("B2:B200").Interior.ColorIndex = xlNone '(Sadece renkli hücrenin zemin rengini siler, veriler kalır)
                Range("B2:B200").Font.Bold = False
            Else
                MsgBox "Temizlenecek kayıt bulunamadı", vbInformation, ""
            End If
    End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Column = 2 And Target.Row > 1 And Target.Row < 200 Then
        Target.Interior.Color = vbYellow
        Target.Font.Bold = True
    End If
End Sub

Sub aktar()
Application.ScreenUpdating = False
    Dim h As Range, r As Byte
    r = 2
        For Each h In Range("B2:B200")
            If h.Interior.Color = vbYellow Then
                h.Copy Range("D" & r)
                r = r + 1
            End If
        Next h
Application.ScreenUpdating = True
End Sub

 

[1Al2Ver]

Sayın AdemCan, tekrar merhaba,

Zahmetleriniz ve çözüm için bir kere daha teşekkür ederim, sağ olun.

Sevgi ve saygılarımla.

 

[AdemCan]

Rica ederim, saygılar.