Aynı hücre gruplarının arasında bir satır boşluk bırakmak

[kgc400]

Ekteki dosyamda aynı olan hücre gruplarının arasında bir satır boş bırakmak istiyorum.Sadece bir tane olanların hem altında hemde üstünde boşluk olmuş olacak.

 

[Ali]

Sub ayır()
toplamsatir = ActiveSheet.UsedRange.Rows.Count
For Row = toplamsatir To 2 Step -1
If Cells(Row, 1).Value <> Cells(Row - 1, 1).Value Then Rows(Row).Insert
Next Row
End Sub

 

[AS3434]

Sayın kgc400

Mesela 0422006EA hem altta hemde üstte yer alıyor.Bunlarında bir araya getirilmesini istiyor musunuz?

Bir araya getirilmiş haliyle hazırladığım dosyayı inceleyin.

 

[AS3434]

Bugün herşeye geç kalıyorum. Sayın Ali cevap vermiş bile.

Kodlarda da hata yapmışım zaten.

Sub ekle()
    say = [a65536].End(3).Row
    Range("a2:a" & say).Select
    Selection.Sort Key1:=Range("a2"), Order1:=xlAscending
    For i = 2 To [COLOR="Red"]say[/COLOR]
    If Cells(i, 1) <> Empty Then
    If Cells(i, 1) <> Cells(i + 1, 1) Then
    Rows(i + 1).EntireRow.Insert
    End If: End If
    Next i
    [A1].Select
End Sub

Kırmızı say yerine 1000 yazın veya tahmini satır sayınızı

 

[zafer]

Merhaba

Bugün herşeye geç kalıyorum. Sayın Ali cevap vermiş bile.

Aynı mesajı yazacaktım.

 

[kgc400]

Sayın Ali çok teşekkürler bu makro işimi gördü.Daha diğer arkadaşların gönderdiklerine bakma fırsatım olmadı.Peki bu boş satılara bu gruplarda kaç tane rakam olduğunu yazmak istiyorum.bunuda makroya ekleyebilir miyiz.

 

[veyselemre]

Sub deneme()
son = [a65536].End(3).Row
Range("a1:a" & son).Sort Key1:=Range("a1"), Order1:=xlAscending
'Sıralamayı iptal etmek isterseniz üsteki satırın başına tek tırnak koyabilirsiniz
For sat = son To 2 Step -1
    If Cells(sat, 1).Value <> Cells(sat - 1, 1).Value Then Rows(sat).Insert
Next sat
son = [a65536].End(3).Row

Range("a1:a" & son + 1).SpecialCells(xlCellTypeBlanks).Select
bas = 1
For Each elm In Selection.Areas
    elm.Value = elm.Row - bas & " adet (" & Cells(elm.Row - 1, 1).Value & ")"
    elm.Font.Bold = True
    bas = elm.Row + 1
Next elm
End Sub