hücreleri işaret kutusuna göre birleştirme

[sorunx]

merhaba arkadaşlar daha forumda yeniyim ekte gönderdiğim dosyada hücre birleştirmenin bir çeşidi hakkında çözüm arıyorum yardımcı olur iseniz sevinirim.

 

[YUSUF44]

Aşağıdaki kodları ilgili sayfanın kod bölümüne yapıştırdığınızda, E, D, F sütunlarında hangi hücreye tıklarsanız ona göre düzenleme yapılır. Sayfanın kod bölümüne geçmek için sayfa sekmesine yani alt kısımdaki sayfa ismine sağ tıklayıp Kod Görüntüle demelisiniz. Ayrıca o kutucuklara gerek yok. Onları iptal edin. Hücreye tıklamanız yeterli.

Private Sub Worksheet_selectionChange(ByVal Target As Range)

If Intersect(Target, Range("E3:g" & Rows.Count)) Is Nothing Then Exit Sub

If Target.Column = 5 Then
    Range(Cells(Target.Row, "E"), Cells(Target.Row, "G")) = ""
    Target = "X"
    Range(Cells(Target.Row, "A"), Cells(Target.Row, "D")) = ""
    Range(Cells(Target.Row, "A"), Cells(Target.Row, "D")).Merge
    Cells(Target.Row, "A") = "RAPORLU"
End If

If Target.Column = 6 Then
    Range(Cells(Target.Row, "E"), Cells(Target.Row, "G")) = ""
    Target = "X"
    Range(Cells(Target.Row, "A"), Cells(Target.Row, "D")) = ""
    Range(Cells(Target.Row, "A"), Cells(Target.Row, "D")).Merge
    Cells(Target.Row, "A") = "YILLIK İZİNLİ"
End If

If Target.Column = 7 Then
    Range(Cells(Target.Row, "E"), Cells(Target.Row, "G")) = ""
    Target = "X"
    Range(Cells(Target.Row, "A"), Cells(Target.Row, "D")) = ""
    Range(Cells(Target.Row, "A"), Cells(Target.Row, "D")).UnMerge
    
    Range(Cells(Target.Row, "A"), Cells(Target.Row, "D")).Borders().LineStyle = xlContinuous
    Range(Cells(Target.Row, "A"), Cells(Target.Row, "D")).Borders(xlDiagonalDown).LineStyle = xlNone
    Range(Cells(Target.Row, "A"), Cells(Target.Row, "D")).Borders(xlDiagonalUp).LineStyle = xlNone

    
End If

Range(Cells(Target.Row, "A"), Cells(Target.Row, "D")).HorizontalAlignment = xlCenter

End Sub

 

[sorunx]

Teşekkürler harika olmuş ellerine sağlık