Macro ile diğer sayfaya koşullu sıralama

[tuncay_p]

Merhaba;
Sitede halihazırda sıralama ile ilgili pekçok örnek var, fakat;
Yapmaya çalıştığım macro yardımı ile A,B ve C sütunlarındaki metinlerin ilk 6 hanesine göre alıp,
Sayfa2 deki A sütünunu sırasına göre (küçükten büyüğe) yazdırmak,
fakat ilk 6 hanesi aynı olan metinleride sadece 1 adet yazması gerekiyor,örneğin 1.1201 den 4 yerde var bunların sadece bir tanesi yazılması gerekiyor).

Yardımlarınız için şimdiden teşekkürler.

 

[Necdet]

Merhaba,

Uzun süre yanıt alamayışınızın gerekçesi, dosyanızın 2007 sürümüne göre hazırlanmış olması. Bilindiği gibi 2007 ofis sürümü herkeste olmayabilir.

Sorunuzu klasik yöntemle çözdüm, gönül isterdi ki CreatObject("Scripting.Dictionary") ile çözüm sunalım. Bir arkadaşım da bu yöntemle çözerse kendi adıma çok sevineceğim.

Sub BaskaSayfadaSirala()
Dim s1 As Worksheet, s2 As Worksheet
Dim i As Long
Dim Hucre As Range
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
s1.Select
s2.Range("A:A").ClearContents
'----- Sayfa1 deki hücrelerin ilk 6 karakteri Sayfa2 ye aktarılıyor ----
For Each Hucre In s1.UsedRange
    If Not IsEmpty(Hucre.Value) Then
        i = i + 1
        s2.Cells(i, "A") = Left(Hucre.Value, 6)
    End If
Next Hucre
'----- Sayfa1 deki hücrelerin ilk 6 karakteri Sayfa2 ye aktarılma sonu ----
'------- Sayfa2 A sütunu sıralanıyor -----------
s2.Range("A1:A" & i).Sort Key1:=s2.[A1]
'------- Sayfa2 A sütunu sıralama sonu -----------
 
'----------Sayfa2 A sütununda çift kayıtlar siliniyor ----------------------
For i = i To 2 Step -1
    If s2.Cells(i, "A") = s2.Cells(i - 1, "A") Then s2.Rows(i).Delete
Next i
'----------Sayfa2 A sütununda çift kayıtlar silindi ----------------------
 
'------- Dilek ve Temenniler :) -------------------------------------------------------------
MsgBox "Sıralama Bitmiştir, İyi Günlerde Kullanınız.....", vbInformation, "[URL="http://www.excel.web.tr/"]www.excel.web.tr[/URL]"
'------- Dilek ve Temenniler ile programın sonu  -------------------------------------------------------------
End Sub

 

[tuncay_p]

Teşekkürler, tam istediğim gibi olmuş.
Başarılar dilerim.