Sıra No Ver Makrosu

[iplikci_80]

Arkadaşlar çalışmadaki B4 hücresinden itibaren veri girdikçe A sütununa sıra numarası verdirmeye yarayan "Sıra No Ver" makrosunu çalıştıramadım. Bu hususta yardımlarınızı rica ediyorum.

 

[byfika]

Merhabalar,
Veri sayfasının kod bölümündeki worksheet_change kodlarını aşağıdaki kodlarla değiştirdiğinizde veya mavi yazılı bölümü ilave ettiğinizde istediğiniz olacaktır. Çalışmayan Sıra No Ver makrosunu silebilirsiniz. ( Sıra No Ver makrosunun çalışması için VERİ sayfasına buton atayıp B sütununa veri girdikten sonra butonla makroyu çalıştırmanız gerekir.) Alttaki kod ile B sütununa veri girildiğinde otomatik olarak sıra no verir.
İyi çalışmalar.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim VERİ() As String, X As Byte, İSİM As String

On Error GoTo Son
If Intersect(Target, Range("B:B")) Is Nothing Then Exit Sub
Application.EnableEvents = False
Target = WorksheetFunction.Proper(Target)
VERİ = Split(Target, " ")
For X = 0 To UBound(VERİ) - 1
İSİM = IIf(İSİM = "", VERİ(X), İSİM & " " & VERİ(X))
Next
Target = İSİM & " " & UCase(Replace(Replace(VERİ(UBound(VERİ)), "ı", "I"), "i", "İ"))
Son:
Application.EnableEvents = True

If Intersect(Target, [B4:B65536]) Is Nothing Then Exit Sub
On Error Resume Next
Target.Offset(0, -1).Value = Target.Row - 3
End Sub

 

[cems]

=EĞER(DEĞİL(EBOŞSA(B4));BAĞ_DEĞ_DOLU_SAY($B4:B$4);"")

Bu formülü a4 hücresine yapıştırın ve istediğiniz kadar aşağı çekerek kopyalayın

 

[çıtır]

Alternatif olsun.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Application.ScreenUpdating = False
Dim t As Integer, sr As Integer
If Intersect(Target, [B4:B65536]) Is Nothing Then Exit Sub
Range("A2:A" & Cells(65536, "A").End(3).Row + 1).ClearContents
For t = 4 To [b65536].End(3).Row
If Not Cells(t, 2) = "" Then
sr = sr + 1
Cells(t, 1) = sr
End If
Next t
On Error GoTo Son
[A4:A65536].SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Son:
Application.ScreenUpdating = True
End Sub

 

[iplikci_80]

Arkadaşlar ilginize çok teşekkür ederim.