Mükerrersiz Alfabetik Sıralama

mcetinkaya65 · 25 Ağustos 2016

Giderler sayfasının c stununda ki isimleri 1'er adet olarak alfabetik bir biçimde bir buton yardımıylaToplu Ödemeler sayfasının C4 hücresinden başlayarak aktarması mümkün mü?

Emir Hüseyin Çoban · 25 Ağustos 2016

. . .

Kod:

Sub KOD()

    Dim SD As Worksheet: Set SD = Sheets("Giderler")
    Dim SO As Worksheet: Set SO = Sheets("Toplu Ödemeler")
    
    Dim liste(), dizi()
    
    Son = SD.Cells(Rows.Count, "C").End(3).Row
    liste = SD.Range("C4:D" & Son).Value
    
   
    Set dic = CreateObject("scripting.dictionary")
    
    For x = 1 To UBound(liste, 1)
        aranan = liste(x, 1)
        If Not dic.exists(aranan) Then
            dic.Add aranan, ""
        End If
    Next x
    
    SO.Range("C:C").ClearContents
    SO.Range("C1") = "Kime Ödendiği"
    SO.Range("C2").Resize(dic.Count, 1) = Application.Transpose(dic.keys)
    
    Son2 = SO.Cells(Rows.Count, "C").End(3).Row
    So.Range("C2:C" & Son2).Sort So.Range("C1"), xlAscending
    
    MsgBox "B i t t i"
End Sub

. . .

YUSUF44 · 25 Ağustos 2016

Aşağıdaki kodu bir modüle kopyalayıp deneyiniz. Kodlar ikinci sayfada K sütununu yardımcı sütun olarak kullanıp benzersizleştirme ve sıralama yaptıktan sonra son listeyi C sütununa kaydeder ve K sütununu siler:

Kod:

Sub hafız()
Set s1 = Sheets("Giderler")
Set s2 = Sheets("Toplu Ödemeler")

son1 = s1.Cells(Rows.Count, "C").End(3).Row
s1.Range("C3 :C" & son1).Copy: s2.[K1].PasteSpecial Paste:=xlValues
s2.Range("$K$1:$K$" & son1).RemoveDuplicates Columns:=1, Header:=xlYes
son2 = s2.Cells(Rows.Count, "K").End(3).Row
s2.Sort.SortFields.Add Key:=Range("K2:K" & son2), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With s2.Sort
        .SetRange Range("K1:K" & son2)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
s2.Range("K2:K" & son2).Copy: s2.[C2].PasteSpecial Paste:=xlValues
s2.Columns("K").Delete
[C1].Select
End Sub

YUSUF44 · 25 Ağustos 2016

Aşağıdaki kodu bir modüle kopyalayıp deneyiniz. Kodlar ikinci sayfada K sütununu yardımcı sütun olarak kullanıp benzersizleştirme ve sıralama yaptıktan sonra son listeyi C sütununa kaydeder ve K sütununu siler:

Kod:

Sub hafız()
Set s1 = Sheets("Giderler")
Set s2 = Sheets("Toplu Ödemeler")

son1 = s1.Cells(Rows.Count, "C").End(3).Row
s1.Range("C3 :C" & son1).Copy: s2.[K1].PasteSpecial Paste:=xlValues
s2.Range("$K$1:$K$" & son1).RemoveDuplicates Columns:=1, Header:=xlYes
son2 = s2.Cells(Rows.Count, "K").End(3).Row
s2.Sort.SortFields.Add Key:=Range("K2:K" & son2), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With s2.Sort
        .SetRange Range("K1:K" & son2)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
s2.Range("K2:K" & son2).Copy: s2.[C2].PasteSpecial Paste:=xlValues
s2.Columns("K").Delete
[C1].Select
End Sub

mcetinkaya65 · 25 Ağustos 2016

İlginize teşekkür ederim.
Allah razı olsun.

Orion1 · 25 Ağustos 2016

Ömer BARAN · 26 Ağustos 2016

Merhaba.

Alternatif olsun.
.

Kod:

[FONT="Arial Narrow"]Sub ALFABETİK_BENZERSİZ()
Set tod = Sheets("Toplu Ödemeler"): Set gid = Sheets("Giderler")
tod.Range("C:C").ClearContents
gid.Range("C3:C" & gid.Cells(65536, 3).End(3).Row).AdvancedFilter _
    Action:=xlFilterCopy, CopyToRange:=tod.[C1], Unique:=True
tod.Range("C2:C" & tod.[C65536].End(3).Row).Sort tod.Range("C1"), xlAscending
tod.[C1] = "Kime Ödendiği": MsgBox "İŞLEM TAMAM..."
End Sub[/FONT]

ZuCChiNi · 26 Ağustos 2016

Faydalandığım bu güzel soruya yardım eden herkese teşekkür ederim.
Bu listelemeyi bir kritere bağlamak mümkün müdür?
Örneğin D sütununda bu ödemelerin türü yer alsın. (Gelir-Gider şeklinde.)
Ben sadece karşısında gelir yazanları bu şekilde sıralamak istiyorum.

Emir Hüseyin Çoban · 26 Ağustos 2016

ZuCChiNi' Alıntı:
Faydalandığım bu güzel soruya yardım eden herkese teşekkür ederim.
Bu listelemeyi bir kritere bağlamak mümkün müdür?
Örneğin D sütununda bu ödemelerin türü yer alsın. (Gelir-Gider şeklinde.)
Ben sadece karşısında gelir yazanları bu şekilde sıralamak istiyorum.

. . .

Kod:

Sub KOD()

    Dim SD As Worksheet: Set SD = Sheets("Giderler")
    Dim SO As Worksheet: Set SO = Sheets("Toplu Ödemeler")

    Dim liste(), dizi()

    Son = SD.Cells(Rows.Count, "C").End(3).Row
    liste = SD.Range("C4:D" & Son).Value


    Set dic = CreateObject("scripting.dictionary")

    For x = 1 To UBound(liste, 1)
[B]        If UCase(Replace(Replace(liste(x, 2), "ı", "I"), "i", "İ")) = "GELİR" Then[/B]
            aranan = liste(x, 1)
            If Not dic.exists(aranan) Then
                dic.Add aranan, ""
            End If
[B]        End If[/B]
    Next x

    SO.Range("C:C").ClearContents
    SO.Range("C1") = "Kime Ödendiği"
[B]    If dic.Count > 0 Then[/B]
        SO.Range("C2").Resize(dic.Count, 1) = Application.Transpose(dic.keys)
   [B] End If[/B]
    Son2 = SO.Cells(Rows.Count, "C").End(3).Row
    SO.Range("C2:C" & Son2).Sort SO.Range("C1"), xlAscending

    MsgBox "B i t t i"
End Sub

. . .

ZuCChiNi · 26 Ağustos 2016

Teşekkür ederim.:bravo:

Erdem Akdemir · 26 Ağustos 2016

Merhaba,

Alternatif olarak kullanabilirsiniz.

Kod:

Sub denemem()

Sayfa2.Range("c2:c1000").ClearContents

Set con = VBA.CreateObject("adodb.Connection")

con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=yes"""

sorgu = "select distinct [Alınan Yer] from [giderler$c3:c1000] where [Alınan Yer] <>'' "

Set rs = con.Execute(sorgu)

Sayfa2.Range("c2").CopyFromRecordset rs

End Sub

ZuCChiNi · 29 Ağustos 2016

@Emir Hüseyin Çoban Beye tekrar teşekkür ederek bir maruzatımı daha belirtmek istiyorum.
Ekteki dosyada olduğu gibi Gelirler sütunum C'de ama isimlerin olduğu sütun L'de. C ve D yanyana iken sorun yok ama sütunlar birbirine ters olunca işler karıştı. Çok kurcaladım ama beceremedim.
Yardımcı olursanız sevinirim.

Emir Hüseyin Çoban · 29 Ağustos 2016

ZuCChiNi' Alıntı:
@Emir Hüseyin Çoban Beye tekrar teşekkür ederek bir maruzatımı daha belirtmek istiyorum.
Ekteki dosyada olduğu gibi Gelirler sütunum C'de ama isimlerin olduğu sütun L'de. C ve D yanyana iken sorun yok ama sütunlar birbirine ters olunca işler karıştı. Çok kurcaladım ama beceremedim.
Yardımcı olursanız sevinirim.

. . .

Kod:

Sub Gelirler()

    Dim SD As Worksheet: Set SD = Sheets("Giderler")
    Dim SO As Worksheet: Set SO = Sheets("Toplu Ödemeler")

    Dim liste(), dizi()

    Son = SD.Cells(Rows.Count, "L").End(3).Row
    liste = SD.Range("C4:L" & Son).Value
    
    Set dic = CreateObject("scripting.dictionary")
    For x = 1 To UBound(liste, 1)
        If UCase(Replace(Replace(liste(x, 1), "ı", "I"), "i", "İ")) = "GELİR" Then
            aranan = liste(x, 10)
            If Not dic.exists(aranan) Then
                dic.Add aranan, ""
            End If
        End If
    Next x

    SO.Range("C:C").ClearContents
    SO.Range("C1") = "Gelirler"
    If dic.Count > 0 Then
        SO.Range("C2").Resize(dic.Count, 1) = Application.Transpose(dic.keys)
    End If
    Son2 = SO.Cells(Rows.Count, "C").End(3).Row
    SO.Range("C2:C" & Son2).Sort SO.Range("C1"), xlAscending

    MsgBox "B i t t i"
    
End Sub

. . .

ZuCChiNi · 29 Ağustos 2016

Çok teşekkür ederim.
Örnekte de belirttiğim gibi yazımdan kaynaklanan listeleme hatasını nasıl çözebiliriz?

ahmet
AHmet
Ahmet

bunları farklı veri olarak görüyor ve ayrı ayrı listeliyor.

Emir Hüseyin Çoban · 29 Ağustos 2016

. . .

Aranan satırını şu şekilde değiştirin.

Kod:

 aranan = [B]UCase(Replace(Replace(liste(x, [COLOR="DarkRed"]10[/COLOR]), "ı", "I"), "i", "İ"))[/B]

. . .

ZuCChiNi · 29 Ağustos 2016

Tekrar teşekkür ederim.
Allah her daim gönlünüze göre versin.

mcetinkaya65 · 29 Ağustos 2016

Sayın Hüseyin Bey;
2 nolu mesajınızdaki makroya 15 nolu mesajdaki makroyu katamazmıyız
Saygılarımla...

Emir Hüseyin Çoban · 29 Ağustos 2016

Buyuk kucuk harfle yazilanlari tek gorme durumunu mu.

.

mcetinkaya65 · 29 Ağustos 2016

Büyük harf küçük harf görme durumu

Emir Hüseyin Çoban · 30 Ağustos 2016

mcetinkaya65' Alıntı:
Büyük harf küçük harf görme durumu

. . .

Küçük denemeler yaparak yapabilirdiniz...

Kod:

aranan = UCase(Replace(Replace(liste(x, [B][COLOR="DarkRed"]1[/COLOR][/B]), "ı", "I"), "i", "İ"))

. . .

Mükerrersiz Alfabetik Sıralama

mcetinkaya65

Ekli dosyalar

Emir Hüseyin Çoban

Destek Ekibi

YUSUF44

Destek Ekibi

YUSUF44

Destek Ekibi

mcetinkaya65

Orion1

Uzman

Ömer BARAN

Uzman

ZuCChiNi

Emir Hüseyin Çoban

Destek Ekibi

ZuCChiNi

Erdem Akdemir

Destek Ekibi

ZuCChiNi

Ekli dosyalar

Emir Hüseyin Çoban

Destek Ekibi

ZuCChiNi

Emir Hüseyin Çoban

Destek Ekibi

ZuCChiNi

mcetinkaya65

Emir Hüseyin Çoban

Destek Ekibi

mcetinkaya65

Emir Hüseyin Çoban

Destek Ekibi