Birden fazla Private Sub Worksheet_Change(ByVal Target As Range) birleştirme

[horzum]

İYİ GÜNLER. AŞAĞIDAKİ KODU BİRLEŞTİREMEDİM.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim bul As Range
Dim trh As Date
Dim CsutunTarih As Date

With ThisWorkbook.Sheets("T1")
If (Target.Column = 3 Or Target.Column = 5) And Target.Row >= 1 Then
If IsDate(Cells(Target.Row, "c")) And Len(Cells(Target.Row, "E") & "") > 0 Then
SonStn = .Cells(1, .Columns.Count).End(xlToLeft).Column
Set bul = .Range("B1:" & .Cells(1, SonStn).Address).Find(Year(Cells(Target.Row, "C").Value), , , 1)
Set kaydir = .Range("A:A").Find(Cells(Target.Row, "E").Value, , , 1)
If (Not bul Is Nothing) And (Not kaydir Is Nothing) Then Cells(Target.Row, "F").Value = .Cells(kaydir.Row, bul.Column).Value
End If
End If
End With
Set bul = Nothing

On Error Resume Next
Dim X As Long, No As Long
If Intersect(Target, Range("B2:B65536")) Is Nothing Then ' B2 koşulun Hangi Hücrede başlayacağını seçin'
Target.Offset(0, -1).Font.Color = vbRed ' Rekli Sayı Verir'
Application.ScreenUpdating = False

For X = 2 To Selection.SpecialCells(xlCellTypeLastCell).Row 'x=2 koşulun Hangi Hücrede başlayacağını seçin'
If Cells(X, "A").MergeArea.Count = 1 Then
If Cells(X, "B") <> "" And Cells(X, "A") <> "Sıra No" Then
No = No + 1
Cells(X, "A") = No
Else
If Cells(X, "A") <> "Sıra No" Then
Cells(X, "A").ClearContents
End If
End If
End If
Next
Application.ScreenUpdating = True
End Sub

 

[Muzaffer Ali]

Merhaba.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim bul As Range
    Dim trh As Date
    Dim CsutunTarih As Date
    Application.ScreenUpdating = False
    
    With ThisWorkbook.Sheets("T1")
        If (Target.Column = 3 Or Target.Column = 5) And Target.Row >= 1 Then
            If IsDate(Cells(Target.Row, "c")) And Len(Cells(Target.Row, "E") & "") > 0 Then
                SonStn = .Cells(1, .Columns.Count).End(xlToLeft).Column
                Set bul = .Range("B1:" & .Cells(1, SonStn).Address).Find(Year(Cells(Target.Row, "C").Value), , , 1)
                Set kaydir = .Range("A:A").Find(Cells(Target.Row, "E").Value, , , 1)
                If (Not bul Is Nothing) And (Not kaydir Is Nothing) Then Cells(Target.Row, "F").Value = .Cells(kaydir.Row, bul.Column).Value
            End If
        End If
    End With
    Set bul = Nothing

    On Error Resume Next
    Dim X As Long, No As Long
    If Intersect(Target, Range("B2:B65536")) Is Nothing Then ' B2 koşulun Hangi Hücrede başlayacağını seçin'
        Target.Offset(0, -1).Font.Color = vbRed ' Rekli Sayı Verir'
        
    
        For X = 2 To Selection.SpecialCells(xlCellTypeLastCell).Row 'x=2 koşulun Hangi Hücrede başlayacağını seçin'
            If Cells(X, "A").MergeArea.Count = 1 Then
                If Cells(X, "B") <> "" And Cells(X, "A") <> "Sıra No" Then
                    No = No + 1
                    Cells(X, "A") = No
                Else
                    If Cells(X, "A") <> "Sıra No" Then
                        Cells(X, "A").ClearContents
                    End If
                End If
            End If
        Next
    End If
    Application.ScreenUpdating = True
End Sub

 

[horzum]

Kardeş Sağolasın A hücresine 1 yazıp enter yapınca hata veriyor.

https://s6.dosya.tc/server13/znqxwm/Subat.xlsm.html