Birleştirilmiş Hücrede Sıralama Yapma

[mbasaranyt]

Başlıkta Belirttiğim gibi Sıralama yapmak istiyorum ancak Birleştirilmiş Hücre olduğu için sıkıntı.Bunu aşmanın yolunu arıyorum.
Örnek Dosya Ekte.
İlgilenen Üstadlara Teşekkürler.

askm Arkadaşın Kodu Doayaya Uygulandı

 

[askm]

Mevcut sıralama kodunuzda E7:S286 arası verileri sıralıyor. Sizin istediğiniz D sütununu dahil etmesi ise,
1. çözüm : Öncelikle unmerge ile d sütununda birleştirilmiş hücreleri ayırın. E ye göre sıralama sonrasında tekrar d sütununu 4 satırda bir step yaparak birleştirin.
2.çözüm : Yine önce sıralama yapın, sonra sırası ile E den verileri tekrar D ye çektirin (Step ile atlatarak)

Yalnız worksheet olayında kodlar olduğu için iki şekilde de bir yavaşlık olacaktır.

 

[mbasaranyt]

worksheet deki makrolar sorun değil Bilgi girişleri bittikten sonra sıralamayı bir kez yaptıracağım
2.çözüm : Yine önce sıralama yapın, sonra sırası ile E den verileri tekrar D ye çektirin (Step ile atlatarak)
bu kısım maro kodunu oluşturamadım

 

[askm]

Sub Siralama()
Dim SonSat As Long
SonSat = Range("E" & Rows.Count).End(xlUp).Row
    Range("E7:S" & SonSat).Sort Key1:=Range("E7"), Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
    'Range("D7:D286").Sort Key1:=Range("D7"), Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
    Range("A1").Select

Range("D7:D" & SonSat).ClearContents
For i = 7 To SonSat Step 4
    Cells(i, 4) = Cells(i, 5)
Next i
End Sub

 

[askm]

Yalnız Worksheet_Change olayından dolayı ilk isim soy ismi siliyor. Koddan önce o kısmı pasif etmeniz gerekiyor.

 

[mbasaranyt]

Sub Siralama()
Dim SonSat As Long
SonSat = Range("E" & Rows.Count).End(xlUp).Row
Range("E7:S" & SonSat).Sort Key1:=Range("E7"), Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
'Range("D7286").Sort Key1:=Range("D7"), Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
Range("A1").Select

Range("D7" & SonSat).ClearContents 'Pasif yapınca oldu gibi teşekkürler
For i = 7 To SonSat Step 4
Cells(i, 4) = Cells(i, 5)
Next i
End Sub

 

[askm]

Daha önceden d de veri olursa diye temizleme kodu eklemiştim. Ama mevcut dosyanıza göre gerek yok sanırım.

 

[mbasaranyt]

makro çok yavaşladı ama olsun teşekkürler

 

[askm]

Yavaşlık olacağınız yazmıştım. Bunu engellemek için sayfa kodlarını pasif yapıp kod işleminden sonra çalıştırabilirsiniz. Bir de Dim tanımından sonra;
Application.ScreenUpdating=False
yazın. End sub dan öncede bu değeri true yapın.

 

[mbasaranyt]

İlgi ve Alakanıza Çok Teşekkür Ederim.

 

[askm]

Rica ederim.