Benzersiz

[turgayzeynep]

Hocam ana veri de F12'den F11 sutununda birçok ülke yazıyor ben bunları telefon tutanağı sayfasına A1: A 111 kadar benzersizleri sıralamasını istiyorum Benim istemiş olduğum kod bu şekilde tam Buna göre tasarlarsanız çok büyük yardımcı olmuş olursunuz teşekkür ederim

Makro ile

 

[kulomer46]

Değerli Arkadaşım Merhaba

Aşağıdaki kodlar seçili alan içindeki kayıtları benzersiz olarak seçili alan içinde listeler.
Excelde benzersiz olarak listesini almak istediğiniz alanı excel hücrelerinde seçiniz.
Sonra bu makro kodunu çalıştırınız.

Hayırlı çalışmalar dilerim.

Sub collection_tekrarlanan_kayıtları_süz()
'25.10.2023  07:32
' Bu program seçili alan içindeki kayıtları benzersiz olarak seçili alan içinde listeler..
'---------------------------------------------------------------------------------
'Collection nesnesini sepet olarak düşünebiliriz. İçine atılan
'nesneleri ayıklayıp, her türden sadece bir çeşit içinde barındırır.

Dim satir, sutun, i, j, k
Dim c
c = MsgBox("Tekrarlanan Kayıtlar silinecek, Emin misiniz?", vbYesNo, "Siliniyor !")
If c = vbNo Then Exit Sub

    Dim col As New Collection ' col değişkeni Collection nesnesi olarak tanımlanıyor..
    Dim rg As Range
    Dim hcr As Range
    Set rg = Intersect(ActiveWindow.Selection, Cells(1, 1).Parent.UsedRange)
    'seçili alan içinde excel tarafından kullanılan hücreler range
    ' olarak tanımlanmış rg nesnesine atılıyor

    On Error Resume Next
    For Each hcr In rg.Cells
        If Trim(hcr) <> "" Or hcr <> empyt Then

            col.Add CStr(Trim(hcr)), CStr(Trim(hcr)) 'rg nesnesine atılan
            'hücreler col adlı collection nesnesine atanıyor.
            'Bu değişken türü aynı türde 2. bir değişkeni bünyesinde barındırmaz..
        End If
    Next

'Aşağıda benzersiz kayıtları seçili alanda soldan sağa yerleştiren kodlar var..
satir = rg.Rows.Count
sutun = rg.Columns.Count
rg.Clear

For i = 1 To satir
        For j = 1 To sutun
            k = k + 1
            If k > col.Count Then MsgBox "Benzersiz " & col.Count & " adet kayıt var.": Exit Sub
            If col.Item(k) <> "" Or col.Item(k) = Empty Then rg.Cells(i, j) = col.Item(k)
      
        Next
    Next
    MsgBox "Hiç benzer kayıt bulunamadı." & Chr(10) & Chr(10) & "Seviliyorsunuz.  Selamlar..."

End Sub

 

[AdemCan]

Merhaba @turgayzeynep
Aynı konuları tekrar açmamanız gerekiyor.
https://excel.web.tr/threads/benzersiz.209357/ bu bağlantıda konunuz devam ediyor.

Ayrıca profil bilgileriniz güncel değil.

Bilgi - Profillerde yazan "Ofis Sürümü ve Dili" bilgisi hakkında

Merhaba Değerli Forum Üyeleri, Belki dikkatinizi çekmiştir. Son zamanlarda birçok üyemize açtıkları başlıklarda cevap vermeden önce "Kullandığınız ofis sürümü ve dili nedir?" şeklinde mesaj yazıyorum. Bu alanın kullanım amacı sizlere verilecek cevaplar için önem arz etmektedir. Bu sebeple bu...

excel.web.tr