Aynı Sütundaki isimleri MsgBox ile sıralama

[Greenblacksea53]

selam herkese,
Bir sütunda 1000 tane verim var aynı olanları msgbox ile nasıl listelerim. Msgbox Alt altta yazacak. Tşklr

 

[Greenblacksea53]

Bir düzelteme yapmak istiyorum sütunda "R" harfi varsa onları alsın istiyorum msgbox 'a

 

[kulomer46]

Merhaba

Ek 'li dosyada seçtiğiniz alan içerisindeki hücrelerde mükerrer aynı olanlar listelenmektedir.

Seçtiğiniz alan tüm sütun yada tüm satır yada excel sayfanızın tamamı olsun, program seçili alan içerisindeki aynı olan ve olmayan verileri Msgbox ile listelemektedir.

Msgbox ile sınırlı sayıda karakter kadar mesaj yazılabilmektedir. Daha fazla karakterde mesaj verilmesi gerektiğinde bu iş için Msgbox değilde kullanıcının hazırlayacağı ve ihtiyaca göre düzenleyeceği User Formların kullanılması tavsiye edilmektedir.

Selamlar...

Ekran Resmi 1



Ekran Resmi 2

 

[kulomer46]

Tekrar Merhaba

Yukardaki #3 numaralı Seçili Alanda Mükerrerlik Kontrolünü bilgisayarınızdaki tüm excel dosyalarında otomatik kullanmak isterseniz aşağıdaki makro kodunu Excel PERSONAL Dosyanıza yapıştırınız. Böylece Mükerrerlik kontrolünü bilgisayarınızdaki tüm excel dosyalarında kullanabilirsiniz.

Selamlar...

Sub Seçimdeki_Benzer_Hücreleri_Bul_Renklendir()
'03.02.2022  12:05

On Error Resume Next
Selection.Font.Bold = False
Selection.Interior.Color = xlNone

sayyhepsi = 0
sayytekrar = 0
sayybenzer = 0
metin1 = ""
metin11 = ""
metintekli = ""
sayytekli = 0
doluvarmi = 0

Dim rg As Range
Set rg = Intersect(ActiveWindow.Selection, Cells(1, 1).Parent.UsedRange)

rg.Select

hücresay = rg.Count
hücresay = Selection.Columns.Count * Selection.Rows.Count

If hücresay > 19999 Then    
    MsgBox "Seçili Alan Çok Büyük" & Chr(10) & Chr(10) & " Benzer Hücreleri Bulma İşlemi İptal Edildi", , "İşlem"
    Exit Sub
End If


For i = 1 To hücresay    

    If Len(Trim(Selection.Item(i))) < 1 Then GoTo uç1   
 
    doluvarmi = 1    
    sayybenzerözel = 0    

    If Selection.Item(i).Font.Bold <> True And Len(Trim(Selection.Item(i))) > 0 Then     
   
'        renk1 = RGB(Int(Rnd * 133) + 121, Int(Rnd * 133) + 121, Int(Rnd * 133) + 121)    

        For ii = i + 1 To hücresay        

            If Selection.Item(ii).Font.Bold <> True And Trim(Selection.Item(i).Value) = Trim(Selection.Item(ii).Value) Then                
                If Selection.Item(i).Font.Bold <> True Then                
                    Selection.Item(i).Font.Bold = True
'                    Selection.Item(i).Interior.Color = renk1
                    sayybenzer = sayybenzer + 1
                    sayybenzertek = sayybenzertek + 1                    
                    metin1 = metin1 & Chr(10) & "   " & Trim(Selection.Item(i)) & ""                    
                End If
                
                Selection.Item(ii).Font.Bold = True
'                Selection.Item(ii).Interior.Color = renk1

'                metin1 = metin1 & "    " & sayybenzerözel + 1 & "  Adet"
                
                sayybenzer = sayybenzer + 1
                sayybenzerözel = sayybenzerözel + 1                
            
            End If
        
        Next
            
        If sayybenzerözel > 0 Then metin1 = metin1 & "    (" & sayybenzerözel + 1 & "  Adet)"        
        
    End If
    
    If Selection.Item(i).Font.Bold <> True And Len(Trim(Selection.Item(i))) > 0 Then
        
        sayytekli = sayytekli + 1

        If metintekli = "" Then

            metintekli = "   " & Trim(Selection.Item(i))

        Else

            metintekli = metintekli & ",   " & Trim(Selection.Item(i))

        End If

    End If
                  
uç1:
Next

If doluvarmi = 0 Then
    
    MsgBox "Seçili Alanda Veri bulunmamaktadır", , "   Seçili Alan Boş   "
    Exit Sub

End If

metin1 = Chr(10) & "Mükerrer Hücreler" & metin1

If Len(Trim(metintekli)) > 0 Then
    
    metintekli = Chr(10) & Chr(10) & "Tekli Hücreler" & Chr(10) & metintekli
    
Else
    
    metintekli = ""

End If
                
If sayybenzer < 1 Then

    MsgBox "Seçili Alanda Mükerrer Hücre Bulunmamaktadır" & metintekli, , "Mükerrer Hücre Bulunmuyor"
    Exit Sub
    
Else
    
    If sayytekli > 0 Then
    
        c = MsgBox("Seçili Alanda  " & sayybenzer & " Adet Mükerrer,  " & sayytekli & " Adet Tekli Hücre Bulunmaktadır" & Chr(10) & Chr(10) & "  Renklendirme Yapılsın mı?" & Chr(10) & metin1 & metintekli, vbOKCancel, sayybenzer & "  Adet Mükerrer Hücre")
        If c = vbCancel Then Exit Sub
    
    Else
    
        c = MsgBox("Seçili Alanda  " & sayybenzer & "  Adet Mükerrer Hücre Bulunmaktadır" & Chr(10) & Chr(10) & "  Renklendirme Yapılsın mı?" & Chr(10) & metin1 & metintekli, vbOKCancel, sayybenzer & "  Adet Mükerrer Hücre")
        If c = vbCancel Then Exit Sub
    
    End If
    
End If

'//////////////////


Selection.Font.Bold = False
Selection.Interior.Color = xlNone

sayyhepsi = 0
sayytekrar = 0
sayybenzer = 0
metin1 = ""

hücresay = Selection.Columns.Count * Selection.Rows.Count

For i = 1 To hücresay
    
    sayybenzerözel = 0
    
    If Selection.Item(i).Font.Bold <> True And Len(Trim(Selection.Item(i))) > 0 Then
        
        renk1 = RGB(Int(Rnd * 133) + 121, Int(Rnd * 133) + 121, Int(Rnd * 133) + 121)
    
        For ii = i + 1 To hücresay
        
            If Selection.Item(ii).Font.Bold <> True And Trim(Selection.Item(i).Value) = Trim(Selection.Item(ii).Value) Then
                
                If Selection.Item(i).Font.Bold <> True Then
                
                    Selection.Item(i).Font.Bold = True
                    Selection.Item(i).Interior.Color = renk1
                    sayybenzer = sayybenzer + 1
                    sayybenzertek = sayybenzertek + 1
                    
                    metin1 = metin1 & Chr(10) & " " & Trim(Selection.Item(i)) & "   yazan hücreden   "
                    
                End If
                
                Selection.Item(ii).Font.Bold = True
                Selection.Item(ii).Interior.Color = renk1
                
                sayybenzer = sayybenzer + 1
                sayybenzerözel = sayybenzerözel + 1
                
            
            End If
        
        Next
        
        If sayybenzerözel > 0 Then metin1 = metin1 & "    " & sayybenzerözel + 1 & "  Adet"
        
        
    End If
    
    
Next
                
If sayybenzer < 1 Then

    MsgBox "Seçili Alanda Aynı Benzer Hücre Bulunmamaktadır", , "Mükerrer Hücre Bulunmuyor"
    
Else

    MsgBox " Seçili Alanda Bulunan Toplam  " & sayybenzer & "  Adet Mükerrrer Hücre Renklendirildi" & Chr(10) & metin1 & metintekli, , "Mükerrer Hücreler Renklendirildi"

End If

End Sub

 

[Greenblacksea53]

Herkese teşekkür ederim, konu listbox kullanarak çözdüm ilginize tekrar teşekkürler