• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Seçilen Sayfa-Sütun-Satır Aralığı benzersiz Sıralama

  • Konbuyu başlatan Konbuyu başlatan modoste
  • Başlangıç tarihi Başlangıç tarihi
M

modoste

Altın Üye
Katılım
31 Mayıs 2008
Mesajlar
3,714
Excel Vers. ve Dili
Microsoft OFFİCE Ev ve İş 2019 TR
merhaba sayın hocalarım
birden fazla çalışma sayfasından(sekme) oluşan dosyamda
makro adını vereceğim yeni bir sekmede
B2 Hücresine= Sayfanın Adı yazılacak
B3 Hücresine = Hangi Sütunun benzersiz Sıralanacağı yazılacak
B4 Hücresine = Kaçıncı satırdan başlayacağı Yazılacak
B5 Hücresine = Kaçıncı satırda biteceği yazılacak

Örnek :
B2= Notlar
B3= L Sütunu
B4= 20
B5= 45

anlamı Notlar çalışma sayfasında L sütunun 20:45 yani L20:L45 arasındaki verilerin benzersiz sıralanmasını veren makroyu yazabilirmisiniz.
olabiliyosa formülle çözümüde olsun
 
Son düzenleme:
Merhaba,

Sıralama nerede yapılacak?
 
evet hocam çok özür diliyorum Sıralama D2 hücresinden başlayacak
 
Ekteki örnek dosyaları inceleyiniz.

İki farklı yöntem kullanılmıştır. Daha da eklenebilir.
 

Ekli dosyalar

sayın korhan hocam teşekkür ederim yeni bakabildim makroya
şimdiki isteğim ise sayfa adlarını birden fazla olarak belirterek belirtilen sayfalarda istenilen satır aralıklarındaki verileri benzersiz sıralamak
satır adlarını C2 den başlayarak aşağıya doğru yazsak satırları ben manuel olarak yazacağım C2 den başlayarak aşağıya doğru devam edecek
bunun makro ile çözümü nasıl yapılır
 
Son düzenleme:
hocam makroları yazarken daha sonra kendimde değişiklik yapabilme şansım olduğunda hangi kısımlar değişebilirse ekrana kırmızı renkle yazabilirmisiniz.
 
Merhaba,

Ekteki dosyayı inceleyiniz.

Yaklaşık 2-3 saniyede listeyi oluşturuyor.

Kriterleri değiştirerek denemeler yapın.
 

Ekli dosyalar

Korhan hocam sen bir harikasın yürekten kutluyorum seni ...
 
hocam çok teşekkür ederim
şimdi bundan sonra olcak sorumuda hem formülle hem makro ile çözümünü sorucam
mantığı şu belli sütunlarda olan verileri benzersiz sıraladık ekli dosyamda ise karışık yerlerdeki verileri nasıl benzersiz sıralayacağız
örneğin A4 de veri var
C8 de veri var AB 26 da veri var
bu tip bir tablo ekleyecem birazadan
 
sayın korhan hocam ve diğer uzman hocalarım
ekli dosyamda sadece 1 sekmeye veri yazdım
bir önceki sorumda sayın hocamın en son çözümü hem ilk sorumun hemde sonraki sorumun çözümünü kapsadığından şimdiki sorumu birden çok sekme için sorcam
ekli dosyada rastgele yerlerde metinler var
yine bir makro ile bir veya birden fazla sekmedeki rastgele yerlerdeki verileri benzersiz nasıl sıralarım

2 tip isteğim olcak
önce her sekmedeki verileri kendi sekmesinin içinde biryerde listeleyecek
dieğride tüm sekmeleri kapsayan bir benzersiz sıralama
bu yapılabilir mi sayın hocalarımdan yardım bekliyorum.
 

Ekli dosyalar

Son düzenleme:
ekli dosyamda kırmızı renkle belirttiğim verileri manuel yazdıktan sonra (yazı olanlar Y sayı olanlar için S) ifadelerini yazıcam ve kritik detay benim kullanıcam tablo bunlara imkan veriyo her verinin solundaki hücreye bu "Y" ile "S" yi yazıcam

makro ile bir yada birden fazla sekmede dağınık yerlerde bir solundaki hücrede "Y" yazanların benzersiz sıralamasını
bir solundaki hücrede "S" yazanların benzersiz sıralamasını ve birde her iki durumdada "Y" de yazsa "S" de yazsa farketmeden benzersiz sıralamasını veren makroları yada makroyu soruyorum çözümü oluyosa çok faydalı bir çalışma olcak şahşım adına

not : ben sadece bir sekmeye veri yazdım
 

Ekli dosyalar

İyi geceler,

Aşağıdaki kodlardan birisini kullanabilirsiniz.

Kod dosyanızda ki tüm sayfaları döngüye alır. Vereceğiniz kriterlere göre arama yapar ve benzersiz verileri boş bir sayfa ekleyip listeler.


Kod-1

Kod: 
Option Explicit

Sub Benzersiz_Liste()
    Dim Kriterler As Variant, S1 As Worksheet, Dizi As New Collection, Satir As Long, Sayfa As Worksheet
    Dim Bul As Range, Adres As String, Kriter() As String, X As Byte, Veri As Variant

    Kriterler = Application.InputBox("Lütfen aradığınız kriterleri arasına " & """-""" & " ekleyerek giriniz...", , "Y-S")
    If Kriterler = False Then Exit Sub
    If Kriterler = "" Then Exit Sub
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    On Error Resume Next
    
    Application.DisplayAlerts = False
    Sheets("Liste").Delete
    Application.DisplayAlerts = True
    
    Satir = 2
    
    For Each Sayfa In ThisWorkbook.Worksheets
        If InStr(1, Kriterler, "-") = 0 Then
            Set Bul = Sayfa.Cells.Find(Kriterler, , , xlWhole)
            If Not Bul Is Nothing Then
                Adres = Bul.Address
                Do
                    Dizi.Add Bul.Offset(0, 1).Text, CStr(Bul.Offset(0, 1).Text)
                    Set Bul = Sayfa.Cells.FindNext(Bul)
                Loop While Not Bul Is Nothing And Bul.Address <> Adres
            End If
        Else
            Kriter = Split(Kriterler, "-")
            For X = 0 To UBound(Kriter)
                Set Bul = Sayfa.Cells.Find(Kriter(X), , , xlWhole)
                If Not Bul Is Nothing Then
                    Adres = Bul.Address
                    Do
                        Dizi.Add Bul.Offset(0, 1).Text, CStr(Bul.Offset(0, 1).Text)
                        Set Bul = Sayfa.Cells.FindNext(Bul)
                    Loop While Not Bul Is Nothing And Bul.Address <> Adres
                End If
            Next
        End If
    Next
    
    On Error GoTo 0
    
    If Dizi.Count > 0 Then
        Set S1 = Sheets.Add
        S1.Name = "Liste"
        S1.Range("A1") = "BENZERSİZ LİSTESİ"
        S1.Range("A1").Font.Bold = True
        S1.Range("A1").Font.ColorIndex = 3
        S1.Range("A:A").HorizontalAlignment = xlCenter
        
        For Each Veri In Dizi
            S1.Cells(Satir, 1) = Veri
            Satir = Satir + 1
        Next
        
        S1.Range("A1").EntireColumn.AutoFit
        
        Set Bul = Nothing
        Set Dizi = Nothing
        Set S1 = Nothing
        
        Application.Calculation = xlCalculationAutomatic
        Application.ScreenUpdating = True
        
        MsgBox "İşleminiz tamamlanmıştır.", vbInformation
    
    Else
        
        Set Bul = Nothing
        Set Dizi = Nothing
        Application.Calculation = xlCalculationAutomatic
        Application.ScreenUpdating = True
        
        MsgBox "Aradığınız kritere uygun kayıt bulunamadı !", vbExclamation
    End If
End Sub


Kod-2

Kod: 
Option Explicit

Sub Sayfalarda_Benzersiz_Verileri_Listele()
    Dim Kriterler As Variant, S1 As Worksheet, Dizi As New Collection, Satir As Long, Sayfa As Worksheet
    Dim Alan As Range, Alan1 As Range, Alan2 As Range, Veri As Range, Kriter() As String, X As Byte, Eleman As Variant

    Kriterler = Application.InputBox("Lütfen aradığınız kriterleri arasına " & """-""" & " ekleyerek giriniz...", , "Y-S")
    If Kriterler = False Then Exit Sub
    If Kriterler = "" Then Exit Sub
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    On Error Resume Next
    Application.DisplayAlerts = False
    Sheets("Liste").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
    
    Satir = 2
    
    For Each Sayfa In ThisWorkbook.Worksheets
        On Error Resume Next
        Set Alan1 = Sayfa.Cells.SpecialCells(xlCellTypeConstants, 23)
        Set Alan2 = Sayfa.Cells.SpecialCells(xlCellTypeFormulas, 23)
        If Alan1 Is Nothing And Alan2 Is Nothing Then
        ElseIf Alan1 Is Nothing Then
            Set Alan = Alan2
        ElseIf Alan2 Is Nothing Then
            Set Alan = Alan1
        Else
            Set Alan = Application.Union(Alan1, Alan2)
        End If
        
        For Each Veri In Alan
            If Veri.Column <> 1 Then
                If InStr(1, Kriterler, "-") = 0 Then
                    If Veri.Offset(0, -1) = Kriterler Then
                        Dizi.Add Veri.Text, CStr(Veri.Text)
                    End If
                Else
                    Kriter = Split(Kriterler, "-")
                    For X = 0 To UBound(Kriter)
                        If Veri.Offset(0, -1) = Kriter(X) Then
                            Dizi.Add Veri.Text, CStr(Veri.Text)
                        End If
                    Next
                End If
            End If
        Next
                
        On Error GoTo 0
        
        Set Alan = Nothing
        Set Alan1 = Nothing
        Set Alan2 = Nothing
    Next
    
    If Dizi.Count > 0 Then
        Set S1 = Sheets.Add
        S1.Name = "Liste"
        S1.Range("A1") = "BENZERSİZ LİSTESİ"
        S1.Range("A1").Font.Bold = True
        S1.Range("A1").Font.ColorIndex = 3
        S1.Range("A:A").HorizontalAlignment = xlCenter
        
        For Each Eleman In Dizi
            S1.Cells(Satir, 1) = Eleman
            Satir = Satir + 1
        Next
        
        S1.Range("A1").EntireColumn.AutoFit
        
        Set Dizi = Nothing
        Set S1 = Nothing
        
        Application.Calculation = xlCalculationAutomatic
        Application.ScreenUpdating = True
        
        MsgBox "İşleminiz tamamlanmıştır.", vbInformation
    
    Else
        
        Set Dizi = Nothing
        Application.Calculation = xlCalculationAutomatic
        Application.ScreenUpdating = True
        
        MsgBox "Aradığınız kritere uygun kayıt bulunamadı !", vbExclamation
    End If
End Sub
 
sayın korhan hocam
makro çözümle ilgili 1. ci kodu şimdi denedim
çözüm için yeni bi sekme açıyo ve tüm sekmeleri işleme alıyo ve dediğiniz gibi işlem yapıyo

daha önceki sorum gibi istenilen sekme adları seçilse ve sekmelerdeki hangi işaretçiye göre "S" "Y" ve varsa başka işaretçileri seçerek benzersiz sıralansa
 
Ekteki örnek dosyayı inceleyin.
 

Ekli dosyalar

sayın korhan hocam bu konuda çok karmaşık şekillerde sorularımı yöneltiyorum ama karşıma çıkan veri kümelerini irdeleyemediğimden belki defalarca yardım istiyorum teşekkür ederim çözümleriniz için
 
korhan hocam
şu çözümleme yapılabiliyorumu
çalışma dosyamda örneğin 20 tane sekme var ve her sekmede az önce belirttiğim gibi metinler ve sayılar var
ve ben ilk soundaki hücreye ("S" , "Y" , yada başka metinsel işaretler bırakıcam.)
benzersiz sıralamayı Liste adında yeni bir sekme oluşturıyodu
şimdiki isteğim ise
çözümlemeyi MAKRO sekmesinde yapıcak ama şöyle yapıcak
seçilen kriter önemli yine "S" "Y" yada başka bir harf
MAKRO sekmesinde B1-C1-D1..... 20 tane sekmenin adını yazcak
B2-C2-D2.den başlamak şartıyla her sekmenin kendi benzersiz listesini oluşturcaz 20 sekme bitincede yanındaki sütunda hepsinin benzersiz listesi olucak.
 
Ekteki örnek dosyayı deneyin.
 

Ekli dosyalar

korhan hocam mükemmelsiniz valla çok teşekkür ederim ben neyi istediğime nasıl bi sonuçlama istediğime hala karar verememişken siz her detay için çözüm ürettiniz
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst