Sıra Numarası Ver ve Ara-Bul Kod Birleştirme

[askm]

Aşağıdaki şekilde 3 tane kod buldum. Benim istediğim; A sütununa sıra numarası verecek. Ama B sütunundaki veriyi silince A daki sıra numarası silinecek. B Sütununa göre B1 e yazdığım kelimeyi arayacak.Ama 3 koddaki gibi renkli ve liste halinde. , Criteria1:="=*" & Deg & "*" kısmı aktif olacak.
Bu 3 kodu birleştiremedim.
1. Kodda Sıra numarası veriyor ve 2 kayıtta bir save yapıyor. En hızlı otomatik sıra numarası veren kod olarak bunu buldum. Bunda Sorum şu: If Target = "" ile hücre boşsa numara vermiyor. Ben B Sütunundaki veriyi silince A daki numaranında silinmesini istiyorum.

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("b2:b65536")) Is Nothing Then Exit Sub
If Target.Count <> 1 Then Exit Sub
If Target = "" Then Exit Sub
ssn = Application.WorksheetFunction.Max(Range("a2" & ":" & "a" & Target.Row - 1))
Target.Offset(0, -1) = ssn + 1

If Target.Offset(0, -1) Mod 2 = 0 Then
ThisWorkbook.Save
End If

2. Kodda Arama yapıyor.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address <> "$A$2" Then Exit Sub
If Target.Text = "" Then
Range("A3").AutoFilter Field:=1
Else
Range("A3" & Range("A65536").End(3).Row).AutoFilter Field:=1, Criteria1:=Range("a2").Text
End If
End Sub

3. Kod yine arama yapıyor. Ama farklı bir sayfaya listeliyor.
Private Sub TextBox1_Change()
Dim sonsat As Long, Deg As String, hcr As Range, Aln As Range, Code As Boolean
Dim vsyf As Worksheet, renk

Sheets("ARAMA").Activate

If Range("E3") <> "" Then
Deg = Range("E3").Value

Else
MsgBox "BİR ARAMA KRİTERİ GİRİN..."
Exit Sub
End If

Application.ScreenUpdating = False
Application.EnableEvents = False

Set vsyf = Sheets("VERİ")
Range("A9:F300").ClearContents


sonsat = vsyf.Range("A" & Rows.Count).End(xlUp).Row
vsyf.Range("B2").AutoFilter

vsyf.Range("B2").AutoFilter Field:=3, Criteria1:="=*" & Deg & "*"

vsyf.Range("B2:F" & sonsat).SpecialCells(xlCellTypeVisible).Copy Range("B9")
vsyf.Range("B2").AutoFilter


sonsat = Range("B" & Rows.Count).End(xlUp).Row
Set Aln = Range("C10:C" & sonsat)

For Each hcr In Aln
renk = InStr(renk + 1, hcr.Text, Deg)
Do
If renk > 0 Then
hcr.Characters(Start:=renk, Length:=Len(Deg)).Font.ColorIndex = 3
End If
renk = InStr(renk + 1, hcr.Text, Deg)
Loop While renk > 0
Next hcr

Application.ScreenUpdating = True
Application.EnableEvents = True

End Sub

 

[YUSUF44]

İlk iki kodun birleşimi aşağıdaki şekilde oluyor:

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("b2:b65536")) Is Nothing Then GoTo 10
If Target.Count <> 1 Then Exit Sub
If Target = "" Then
    Target.Offset(0, -1) = ""
Else
    ssn = Application.WorksheetFunction.Max(Range("a2" & ":" & "a" & Target.Row - 1))
    Target.Offset(0, -1) = ssn + 1
End If
If Target.Offset(0, -1) Mod 2 = 0 Then
    ThisWorkbook.Save
End If

10:
If Target.Address <> "$A$2" Then Exit Sub
If Target.Text = "" Then
    Range("A3").AutoFilter Field:=1
Else
    Range("A3" & Range("A65536").End(3).Row).AutoFilter Field:=1, Criteria1:=Range("a2").Text
    Target.Select
End If
End Sub

 

[askm]

Kodu B1 hücresine göre değiştirdim ve içerisinde geçen şekilde yaptım ama yazarken filtreleme nasıl işlem yapacağım ve renklendirme yapmayı da bilmiyorum.
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("b2:b65536")) Is Nothing Then GoTo 10
If Target.Count <> 1 Then Exit Sub
If Target = "" Then
Target.Offset(0, -1) = ""
Else
ssn = Application.WorksheetFunction.Max(Range("a2" & ":" & "a" & Target.Row - 1))
Target.Offset(0, -1) = ssn + 1
End If
If Target.Offset(0, -1) Mod 2 = 0 Then
ThisWorkbook.Save
End If

10:
If Target.Address <> "$B$1" Then Exit Sub
If Target.Text = "" Then
Range("B2").AutoFilter Field:=1
Else
Range("B2" & Range("B65536").End(3).Row).AutoFilter Field:=2, Criteria1:="*" & Range("B1").Text & "*"
Target.Select
End If
End Sub

 

[YUSUF44]

Hücreye yazarken Excel'in hiçbir özelliği çalışmaz. Onun için üçüncü kod textbox'a yazılmış.

İsteğiniz bana karışık geldiği için ilgilenemedim maalesef.

 

[askm]

3. Kodda farklı sayfaya kopyalama yapıyor. Benim istediğim aynı sayfada süzme yapsın. TextBox da eklerim. Ama aynı sayfada nasıl yapacağımı bilemedim.

 

[YUSUF44]

Verdiğim (daha doğrusu sizin verdiğiniz benim güncellediğim) kod zaten aynı sayfada süzüyor.

 

[askm]

Renk ekleme yapmıyor ama.

 

[YUSUF44]

Dediğim gibi o kısım karışık geldiği için uğraşamadım maalesef.