Sicilleri kendi arasında sıralama

[ASLAN7410]

Merhaba, herkese hayırlı geceler.

Ekte gönderdiğim excel dosyamın B sütununda siciller var, F sütunundada personellerin çalıştığı yerler var, her personel farklı yerlerde çalışıyor, aynı yerlerde çalışan personeller alt alta yazılı, personellerin çalıştığı yer farklı olduğunda personeller arasında 1 boş satır var.

Benim yapmak istediğim butona bastığımda personeller sicillerine göre kendi arasında sıralanmasını istiyorum.

Yardımcı olur musunuz?
.

 

[cems]

Önce unvana göre sonra sicile göre sıralar ve son olarak da unvanlar arasına 1 satır boşluk ekler. Kod 100 satıra ayarlı, siz bunu istediğiniz gibi " 100 " olan yerlerde değiştirin .

Sub siralaayir()

    Range("A3:F100").Select
    ActiveWorkbook.Worksheets("Sayfa1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sayfa1").Sort.SortFields.Add Key:=Range("F3:F100") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Sayfa1").Sort.SortFields.Add Key:=Range("B3:B100") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Sayfa1").Sort
        .SetRange Range("A3:F100")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("A1").Select
    
 With Sheets("Sayfa1")
For i = 2 To .Range("f65536").End(2).Row
If .Cells(i + 1, 6).Value <> .Cells(i, 6).Value Then
.Rows(i + 1).Insert Shift:=xlDown
i = i + 1
End If
Next i
End With
MsgBox "Sicile göre yeniden dizme ve unvana göre gruplandırma gerçekleşti"
ThisWorkbook.Save
End Sub

 

[ASLAN7410]

Sayın cems, ilginiz için çok teşekkür ederim, yazmış olduğunuz kod gayet güzel çalışıyor, ancak başlık altına da 1 boşluk atıyor, ayrıca F sütununun sıralamasına gerek yok. Sadece siciller, çalıştığı yere göre kendi aralarında sıralanmasını ve aralarına 1 boşluk atmasını istiyorum.

 

[ASLAN7410]

Arkadaşlar, konu günceldir.

 

[ASLAN7410]

Arkadaşlar konuyu çözemedim, konu hala günceldir.

Yardımcı olur musunuz?

Yapmak istediğim şekil ekteki resimdeki gibi.
.

 

[Asri]

Alternatif;

Aşağıdaki şekilde deneyiniz.

Dim basla, bitir As Long

Sub ozel_sirala()
   Application.ScreenUpdating = False
   Application.DisplayAlerts = False
   sonsatir = Cells(Rows.Count, "B").End(3).Row
   basla = 3
   For i = 3 To sonsatir +1
     veri = Cells(i, "B").Value
     If veri = "" Then
        bitir = i - 1
        Call sirala
        basla = i + 1
     End If
   Next i
   satir = 0
   For i = 3 To sonsatir
      If Cells(i, "B").Value <> "" Then
         satir = satir + 1
         Cells(i, "A").Value = satir
      End If
   Next i
   Application.ScreenUpdating = True
   Application.DisplayAlerts = True
End Sub

Sub sirala()
    secim1 = "A" & basla & ":F" & bitir
    secim2 = "B" & basla & ":B" & bitir
    
    Range(secim1).Select
    ActiveWorkbook.Worksheets(ActiveSheet.Name).Sort.SortFields.Clear
    ActiveWorkbook.Worksheets(ActiveSheet.Name).Sort.SortFields.Add Key:=Range(secim2), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets(ActiveSheet.Name).Sort
        .SetRange Range(secim1)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("B3").Select
End Sub

 

[ASLAN7410]

Sayın Asri Bey, ellerinize sağlık, valla süper oldu, çok teşekkür ediyorum.

Kod tam istediğim gibi çalışıyor, hayırlı geceler, hayırlı çalışmalar diliyorum.

 

[Asri]

Sayın Asri Bey, ellerinize sağlık, valla süper oldu, çok teşekkür ediyorum.

Kod tam istediğim gibi çalışıyor, hayırlı geceler, hayırlı çalışmalar diliyorum.

Kod da sonsatir +1 güncellemesi yaptım.
Son güncellemeyi kullanınız. İlk kodlar en son grubu sıralamayacaktır.

 

[ASLAN7410]

Tamam Asri Bey, aldım son kodu çok teşekkür ediyorum, hayırlı geceler diliyorum.