Satır ekleme

[artifical]

merhabalar,

örnek dosyadaki gibi iller arasına satır eklemem gerekiyor. yani adana'dan sonraki il satırına geldiğinde bir satır boşluk açmalı. ayrıca illerin yanındaki değerlere göre adana kendi içinde sort edilmeli. ve ayrıca sort edildikten sonrada her il için 1'den başlayarak no ile yazılı sütuna sıra ile değerler vermeli. yani adana 29 tane ise 1'den 29'a kadar olmalı ve sonrasında adapazarı 23 tane ise 1'den 23'e kadar değer almalı.

ben kendimce bişeyler yaptım ama çokda işe yaramadı.
Private Sub ayırma()
Dim adet As Integer
Dim ilk As Integer
Dim son As Integer
Range("D").Select
adet = Application.CountA(Selection) - 1

For i = 2 To adet
ilk = Cells(i, 4).Select
son = Cells(i + 1, 4).Select
If ilk = son Then
GoTo has
ElseIf ilk <> son Then
ActiveCell.EntireRow.Select
i = i - 1
End If
has:
Next i
End Sub

yazdığım kodta ne gibi hatalar yaptığımı söyleyecek arkadaşlarada minnettar olurum. böylece hatalarımı ve eksiklerimide görmüş olurum.

Ustalarıma şimdiden teşekkür ederim...

 

[Necdet]

Merhaba,

Aşağıdaki kodları dener misiniz?

Sub SatirAc()
Dim i As Long
Application.ScreenUpdating = False
Range("B2:C" & [B65536].End(3).Row).Sort Key1:=[B2]
Range("A2").FormulaR1C1 = "=COUNTIF(R2C2:RC[1],RC[1])"
Range("A2:A" & [B65536].End(3).Row).FillDown
For i = [B65536].End(3).Row To 3 Step -1
    If Cells(i, "B") <> Cells(i - 1, "b") Then Rows(i).Insert Shift:=xlDown
Next i
Application.ScreenUpdating = True
MsgBox "İşlem Tamamdır...."
End Sub

 

[artifical]

elinize sağlık

Hocam çok teşekkürler. Şiir gibi çalışıyor

 

[Necdet]

Kafiyesini merak ettim

 

[evren_01]

pardon yanlış yere konu açtım

 

[Necdet]

Tekrar Merhaba,

Sıra numarası için fonksiyon yavaşlatırsa çalışmayı aşağıdaki kodları kullanabilirsiniz.

Sub SatirAc()
Dim i, SıraNo As Long
Dim EskiDeğer As String
Application.ScreenUpdating = False
Range("B2:C" & [B65536].End(3).Row).Sort Key1:=[B2]
For i = 2 To [B65536].End(3).Row
    If EskiDeğer <> Cells(i, "B") Then
        SıraNo = 0
        EskiDeğer = Cells(i, "B")
    End If
    
    SıraNo = SıraNo + 1
    Cells(i, "A") = SıraNo
    
Next i
For i = [B65536].End(3).Row To 3 Step -1
    If Cells(i, "B") <> Cells(i - 1, "b") Then Rows(i).Insert Shift:=xlDown
Next i
Application.ScreenUpdating = True
MsgBox "İşlem Tamamdır...."
End Sub

 

[artifical]

Evet hocam gerçektende hız olarak çok farketti. elinize sağlık.

makronun makamı olmazmı hocam. helede tıkır tıkır çalışan bir makro çok güzel bir keyif bence.

 

[Necdet]

Güle güle kullanınız.