Kolay gelsin arkadaşlar...
Kod:
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo 10
Application.EnableEvents = False
Range("A7:A15000").ClearContents
No = 1
Select Case Target.Column
Case 1 To 6
For X = 7 To 15000
If Cells(X, 2) <> "" And Cells(X, 2) <> "" Then
Cells(X, 1) = No
No = No + 1
End If
Next
End Select
10 Application.EnableEvents = True
End Sub
Yukarıdaki kod ile
Excel de otomatik satır numarası verilmekte. Ancak Range("A7:A15000").ClearContents olarak satır sınırlamasını 15000 olarak sınırlandırdım. Son satırdaki 15000'den küçük yani satır sayısı Örneğin:2845 olduğunda otomatik olarak sayı vermiyor. 15000 sınırlandırmasını Range("A7:A").ClearContents yapıncada otomatik sayı vermiyor. Sınırlandırma olmadan otomatik sayı vermeyi nasıl halledebilir.
Saygılar....!
(13/09/2023, 15:24)HORZUM yazdı: [ -> ]Cells(X, 2) <> "" And Cells(X, 2) <> ""
Merhaba.
Öncelikle yukarda 2 kere yazılmış aynı kriter.Sonrasında ise örnek eklemenizde fayda var sizin için.
Bu arada kodun daha hızlı olması için alttaki kodlardan birini kullanabilirsiniz.
Tabii normali olan ilk kod.
Kod:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim arr(), dizi
Const sonSatir As Long = 15000
Application.EnableEvents = False
If Not Intersect(Target, Range("A7:F" & sonSatir)) Is Nothing Then
Range("A7:A" & sonSatir).ClearContents
On Error GoTo 10
dizi = Range("B7:B" & sonSatir).Value2
No = 1
ReDim arr(1 To sonSatir, 1 To 1)
For x = 1 To UBound(dizi)
If dizi(x, 1) <> "" Then
arr(x, 1) = No
No = No + 1
End If
Next
Range("A7").Resize(UBound(arr), 1).Value = arr
End If
Application.EnableEvents = True
Exit Sub
10
Range("A7:A" & sonSatir).ClearContents 'Hata durumunda tümünü silmek icin
Application.EnableEvents = True
MsgBox "Hata oldu", vbCritical, "Hata"
End Sub
Kod:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim arr(), dizi
Const sonSatir As Long = 15000
Application.EnableEvents = False
Range("A7:A" & sonSatir).ClearContents
On Error GoTo 10
dizi = Range("B7:B" & sonSatir).Value2
No = 1
Select Case Target.Column
Case 1 To 6
ReDim arr(1 To sonSatir, 1 To 1)
For x = 1 To UBound(dizi)
If dizi(x, 1) <> "" Then
arr(x, 1) = No
No = No + 1
End If
Next
End Select
Range("A7").Resize(UBound(arr), 1).Value = arr
Application.EnableEvents = True
Exit Sub
10
Range("A7:A" & sonSatir).ClearContents 'Hata durumunda tümünü silmek icin
Application.EnableEvents = True
MsgBox "Hata oldu", vbCritical, "Hata"
End Sub
(13/09/2023, 17:58)feraz yazdı: [ -> ]Bu arada kodun daha hızlı olması için alttaki kodlardan birini kullanabilirsiniz.
Tabii normali olan ilk kod.
Kod:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim arr(), dizi
Const sonSatir As Long = 15000
Application.EnableEvents = False
If Not Intersect(Target, Range("A7:F" & sonSatir)) Is Nothing Then
Range("A7:A" & sonSatir).ClearContents
On Error GoTo 10
dizi = Range("B7:B" & sonSatir).Value2
No = 1
ReDim arr(1 To sonSatir, 1 To 1)
For x = 1 To UBound(dizi)
If dizi(x, 1) <> "" Then
arr(x, 1) = No
No = No + 1
End If
Next
Range("A7").Resize(UBound(arr), 1).Value = arr
End If
Application.EnableEvents = True
Exit Sub
10
Range("A7:A" & sonSatir).ClearContents 'Hata durumunda tümünü silmek icin
Application.EnableEvents = True
MsgBox "Hata oldu", vbCritical, "Hata"
End Sub
Kod:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim arr(), dizi
Const sonSatir As Long = 15000
Application.EnableEvents = False
Range("A7:A" & sonSatir).ClearContents
On Error GoTo 10
dizi = Range("B7:B" & sonSatir).Value2
No = 1
Select Case Target.Column
Case 1 To 6
ReDim arr(1 To sonSatir, 1 To 1)
For x = 1 To UBound(dizi)
If dizi(x, 1) <> "" Then
arr(x, 1) = No
No = No + 1
End If
Next
End Select
Range("A7").Resize(UBound(arr), 1).Value = arr
Application.EnableEvents = True
Exit Sub
10
Range("A7:A" & sonSatir).ClearContents 'Hata durumunda tümünü silmek icin
Application.EnableEvents = True
MsgBox "Hata oldu", vbCritical, "Hata"
End Sub
Teşekkür ederim feraz Hocam...
1. Kod ve 2. Kod Range("A7:A" & sonSatir).ClearContents kısmında hata veriyor. Range("A7" & sonSatir).ClearContents olarak düzeltince de en son satırdaki bilgileri siliyor
Rica ederim.Hatayı görmek için öncedende dediğim gibi ek eklemeniz faydanıza.