makro ile sıralama

[cumaliyagtu]

arkadaşlar makro ile yukardan aşağıya, küçükten büyük olarak nasıl sıralama yaptırabilirim bu dosyadaki verilere ?Yardımlarınız için şimdiden teşekkür ederim.
Örnek dosya ektedir.

 

[bzace]

Dosyanız bozuk.Bir daha göz atıp yüklermisiniz.

 

[Murat OSMA]

Sn. bzace, dosyanın bozuk olduğunu nereden anladınız ?

 

[cumaliyagtu]

arkadaşlar bende açılıyor ama bozuksa eğer .rar yapıp tekrar gönderirim. Saygılar..

 

[Murat OSMA]

Dosyayı sıkıştırınca dosya düzelmez, şıkıştırıp gönderseniz de açılmayacaktır. Ama bende sorunsuz açılıyor. Açamayan arkadaşlar güvenlik ayarlarını kontrol etmeli..


Açılmamasının sebebi: Güven Merkezi ayarlarındaki Korumalı Görünüm kısmındaki seçili CheckBox'lar..

Resimde de göreceğiniz gibi tüm CheckBox'ların seçimini iptal ettim ve açıldı..

 

[cumaliyagtu]

ilk dosyayı güncelledim, sanırım sn.bzace nin dediği gibi dosya arızalıydı. Heralde bu yüzden yanıt alamadım. İlgili dosya için makro yazan bir üstadımız olursa sevinirim.

 

[Murat OSMA]

Dosya içindeki uzun anlatımı okumak istemedim. Daha kısa ve net bir biçimde anlatabilirseniz yardımcı olmaya çalışırım..

 

[cumaliyagtu]

Dosya içindeki uzun anlatımı okumak istemedim. Daha kısa ve net bir biçimde anlatabilirseniz yardımcı olmaya çalışırım..

Hocam anlatımı cok kısa tuttum, bir bakarsanız sevinirim tesekurler

 

[Murat OSMA]

Deneyiniz;

Sub Git_Ara_Bul_Getir()
    Dim Rky As Range, sat As Integer, sut As String
    sat = Mid(Range("A14").Value, 2, 2) + 1
    sut = Left(Range("A14").Value, 1)
    For Each Rky In Range("B1:E10,H1:K10,N1:Q10,T1:W10,Z1:AC10,AF1:AI9")
        If Rky.Value = Range("A12").Value Then
            Range(sut & sat).End(3)(2, 1) = Rky.End(xlToLeft).Value
            sat = sat + 1
        End If
    Next Rky
    Set Rky = Nothing: sat = Empty: sut = ""
End Sub

 

[cumaliyagtu]

Hocam elinize sağlık güzel olmuş, yalnız şu var mesela bu seferde A17 sütununa değilde B17 sütununa (yani B17 hücresinden itibaren aşağıya doğru) 9 lar yerine 10 rakamlarını içeren dörtlüleri yazdır dediğimde bu sefer sütunu doğru tutturuyor fakat yerini tuturamıyor, B17 Hücresinden aşağıya doğru yazdıracağına, B13 hücresinden aşağıya doğru yazdırıyor. Sütun ataması biraz sorunlu gibi..

Birde üstadım bu dörtlüler içerisinde tek rakam değilde mesela iki rakam arasa o zaman kod nasıl değişirdi, mesela örnekte 9 rakamı vardır dimi, ama ben şimdi 9 ve 6 rakamını içerenleri yazdır demek istesem yani A12 deki mevcut 9 rakamı kalsa yanına B12 ye 6 yazssam bana 6 ve 9 ları içerenleri yazdır desem o zaman kod nasıl olurdu. Onuda yazarmısınız lütfen.. Elinize sağlık..Teşekürler..

 

[Murat OSMA]

Anladım..

Sütun için bu satırı; Range(sut & sat).End(3)(2, 1) = Rky.End(xlToLeft).Value
Bu satır ile değiştirin; Range(sut & sat).Value = Rky.End(xlToLeft).Value

Diğeri için birazdan dönerim.


İlave soru: 2 farklı rakam arandığında yazılacak olan sütun ve hücre adresi ne olacak ?

 

[Murat OSMA]

Alt alta sıralamak için;

Sub Git_Ara_Bul_Getir()
    Dim Rky As Range, sat As Integer, sut As String
    sat = Mid(Range("A14").Value, 2, 2) + 1
    sut = Left(Range("A14").Value, 1)
    For Each Rky In Range("B1:E10,H1:K10,N1:Q10,T1:W10,Z1:AC10,AF1:AI9")
        For i = 1 To 4
            If Rky.Value = Cells(12, i) Then
                Range(sut & sat).Value = Rky.End(xlToLeft).Value
                sat = sat + 1
            End If
        Next i
    Next Rky
    Set Rky = Nothing: sat = Empty: sut = ""
End Sub

 

[Murat OSMA]

Bir cevap verecek misiniz ?
Çıkacağım sizi bekliyorum.

 

[Murat OSMA]

Cevap vermediniz...

Yan yana yazmak için bu kodları kullanabilirsiniz;

Sub Git_Ara_Bul_Getir()
    Dim Rky As Range, sat As Integer, sut As String
    sat = Mid(Range("A14").Value, 2, 2) + 1
    sut = Left(Range("A14").Value, 1)
    Range("A16:AI100").ClearContents
    For i = 1 To 4
        If Cells(12, i) <> 0 Then Cells(sat - 1, i) = Cells(12, i) & "'lar"
        For Each Rky In Range("B1:E10,H1:K10,N1:Q10,T1:W10,Z1:AC10,AF1:AI9")
            If Rky.Value = Cells(12, i) Then
                Cells(sat, i) = Rky.End(xlToLeft).Value
                sat = sat + 1
            End If
        Next Rky
        sat = Mid(Range("A14").Value, 2, 2) + 1
    Next i
    Set Rky = Nothing: sat = Empty: sut = ""
End Sub

İyi akşamlar..

 

[cumaliyagtu]

şimdi bakıyorum, bende cevabı bekliyordum ikinci sayfaya geçmişiz meğersem yeni fak ettim .. test ediyorum su an

 

[cumaliyagtu]

Anladım..

Sütun için bu satırı; Range(sut & sat).End(3)(2, 1) = Rky.End(xlToLeft).Value
Bu satır ile değiştirin; Range(sut & sat).Value = Rky.End(xlToLeft).Value

Diğeri için birazdan dönerim.


İlave soru: 2 farklı rakam arandığında yazılacak olan sütun ve hücre adresi ne olacak ?

Harika olmuş, elleriniz dert görmesin.Teşekürler ederim.

Birde su dikkatimi çekti, 7 rakamını arıyouz diyelimki, 16 rakamına ait dörtlükte 3 tane 7 rakamı var, program 16 rakamını 3 kere altalta yazıyor oysam 1 kere yazması yeterli. Mükerrer tekrarı önleyecek bir kod satırı eklemek mümkünmüdür?

İlave soru: 2 farklı rakam arandığında yazılacak olan sütun ve hücre adresi ne olacak ?

Sorunuza cevaben 2 farklı rakam arandığında yine aynı mantıkla çalışacak, hangi dörtlü içerisinde ise bu iki rakam onun temsili rakamını (yani kırmızı rakamını ) yine A14 hücresinde yazmış olduğum sütün adresine aynı mantıkla yazdıracak.. 3 rakam olursada aynı şekilde.. Sizede iyi akşamlar. Yarına kalır artık .

 

[Murat OSMA]

Soruma verdiğiniz cevaptan, bütün aranan değerlerin alt alta yazılacağını anlıyorum doğru mudur ? Oysa dosyanızda 9 lar 11 ler gib ayrı ayrıydı... :dusun:


Mükerrerlerin silinmesi için ise şu kodları ilave edebilirsiniz;

ActiveSheet.Range("$A$16:$A$100").RemoveDuplicates Columns:=1, Header:=xlYes

 

[cumaliyagtu]

ayrı ayrı olucak hocam alta alta değil.
Mesela 6 ve 9 her iki rakamda tüm dortluklerde aranmış ve A14 hücresinde atamıs olduğumuz sütün adresine yukardan aşağıya ve küçükten büyüğe dogru yazdırılmış. Yani evet 9 lar 11 ler gibi ayrı ayrı.

Mesela A12 hücresine 10 rakamını, B12 ye de 12 rakamını yazdım. 10-12 rakamlarını içerenleri git tüm dörtlüklerde ara bul ve A14 teki atanmış olan sütüna yazdır gibi..

ActiveSheet.Range("$A$16:$A$100").RemoveDuplicates Columns:=1, Header:=xlYes

Hocam bu kodun yeri yazmış olduğunuz kod içerisinde neresidir, For-Next dongusu satırının sonuna koydum olmadı, değişken tanımladığınız satırın altına denedim olmadı?

 

[Murat OSMA]

ayrı ayrı olucak hocam alta alta değil.
Mesela 6 ve 9 her iki rakamda tüm dortluklerde aranmış ve A14 hücresinde atamıs olduğumuz sütün adresine yukardan aşağıya ve küçükten büyüğe dogru yazdırılmış. Yani evet 9 lar 11 ler gibi ayrı ayrı.


Mesela A12 hücreine 10 rakamını, B12 ye de 12 rakamını yazdım. 10-12 rakamalrını içerenleri git tüm dörtlüklerde ara bul ve A14 teki atanmış olan sütüna yazdır gibi..

Bir yerde anlaşamıyoruz.

A14 hücreisne A16 yazıp aranan 6 - 9 -11 gibi rakamları nasıl A14 hücresinde atamış olduğunuz sütün adresine yukarıdan aşağıya ve küçükten büyüğe doğru listeleyeceksiniz ? :dusun: :dusun: :dusun:
Bu durumda alt alta listelemiş olacak.. Farklı adresler vermelisiniz ki ayrı ayrı listelesin.

ActiveSheet.Range("$A$16:$A$100").RemoveDuplicates Columns:=1, Header:=xlYes

Next i satırından sonra, ya da End Sub satırından önce bütün işlemler bittikten sonra teke düşürecek.

 

[cumaliyagtu]

Haklısınız, farklı adresler verdiğimde ayrı ayrı listelesin , aynı adres verdiğimde ise alt alta listelesin. Sizin dediğiniz gibi bölesi bencede mantıken en doğrusu..

Kodu End sub tan önce denedim beceremedim

Set Rky = Nothing: sat = Empty: sut = ""
ActiveSheet.Range("$A$16:$A$100").RemoveDuplicates Columns:=1, Header:=xlYes
End Sub