Tablo Düzenlemesi

[ta2uk]

Selamlar;
Ekte bulunan örnek dosyada, sayfa1 de yer alan verileri sayfa2 deki gibi düzenlemek istiyorum.
Buna göre;

• A sütununda aynı ID ye sahip olan satır gruplarında, D sütununda yer alan isimler kendi aralarında alfabetik sırayla dizilmeli,

• D sütununda önce a harfi ile başlayan grup, sonra b harfiyle başlayan grup şeklinde genel bir düzenleme olmalı,
• 
  
• A sütununda aynı değeri taşıyan satır grupları arasında 1 boş satır olmalı şeklinde bir düzenlemeye ihtiyacım var.

Orijinal tablomda 9000 kadar satır bulunmaktadır. yardımcı olacak arkadaşlara şimdiden çok teşekkür ederim.

 

[Necdet]

Merhaba,
Doğru anlamışımdır umarım, aşağıdaki kodları bir modüle kopyalayıp deneyiniz.

Public Sub Duzenle()

Dim i As Long
Dim j As Integer

Application.ScreenUpdating = False

i = Cells(Rows.Count, "A").End(3).Row
j = Range("A1").End(xlToRight).Column

Range(Cells(2, 1), Cells(i, j)).Sort Key1:=[A1], Key2:=[D1]

For i = i To 3 Step -1
    If Cells(i, "A") <> Cells(i - 1, "A") Then Rows(i).Insert
Next i

Application.ScreenUpdating = True

MsgBox "Tamamdır..."

End Sub

 

[ta2uk]

Merhaba,
Doğru anlamışımdır umarım, aşağıdaki kodları bir modüle kopyalayıp deneyiniz.

Public Sub Duzenle()

Dim i As Long
Dim j As Integer

Application.ScreenUpdating = False

i = Cells(Rows.Count, "A").End(3).Row
j = Range("A1").End(xlToRight).Column

Range(Cells(2, 1), Cells(i, j)).Sort Key1:=[A1], Key2:=[D1]

For i = i To 3 Step -1
    If Cells(i, "A") <> Cells(i - 1, "A") Then Rows(i).Insert
Next i

Application.ScreenUpdating = True

MsgBox "Tamamdır..."

End Sub

Üstat elinize sağlık, çok güzel çalışıyor. Ancak tablo düzenli hale gelince ön görmediğim bir sorun ortaya çıktı. Şayet gruplar sadece aynı isimden oluşuyorsa o grubu silebilir miyiz? Örnek dosyayı ekledim. Teşekkürler şimdiden.

 

[Necdet]

Merhaba,
Önceki düzenleme kodundan sonra aşağıdaki kodları çağırınız..

Sub Makro()
    
Dim i   As Long
Dim j   As Long
Dim bsr As Long
Dim adt As Integer

Application.ScreenUpdating = False

i = Cells(Rows.Count, "A").End(3).Row

j = 2

Do
    bsr = j
    j = Range("D" & bsr).End(xlDown).Row
    If j = Rows.Count Then Exit Do
    adt = j - bsr + 1
    If adt > 1 Then
        If WorksheetFunction.CountIf(Range("D" & bsr & ":D" & j), Range("D" & bsr)) = adt Then
            Rows(bsr & ":" & j + 1).Delete
            j = bsr
        Else
            j = j + 2
        End If
    End If
Loop Until j > i
    
Application.ScreenUpdating = True

MsgBox "işlem tamamdır."
End Sub

 

[ta2uk]

Merhaba,
Önceki düzenleme kodundan sonra aşağıdaki kodları çağırınız..

Sub Makro()
   
Dim i   As Long
Dim j   As Long
Dim bsr As Long
Dim adt As Integer

Application.ScreenUpdating = False

i = Cells(Rows.Count, "A").End(3).Row

j = 2

Do
    bsr = j
    j = Range("D" & bsr).End(xlDown).Row
    If j = Rows.Count Then Exit Do
    adt = j - bsr + 1
    If adt > 1 Then
        If WorksheetFunction.CountIf(Range("D" & bsr & ":D" & j), Range("D" & bsr)) = adt Then
            Rows(bsr & ":" & j + 1).Delete
            j = bsr
        Else
            j = j + 2
        End If
    End If
Loop Until j > i
   
Application.ScreenUpdating = True

MsgBox "işlem tamamdır."
End Sub

Elinize sağlık çok teşekkür ederim...