Sütun İçeriği Karşılaştırmak...

[ta2uk]

Merhabalar,

Elimde örneğini ekte verdiğim bir tablo var.
İsteğim Q sütunundaki sayıları tek tek diğer sütunlardaki sayılar ile karşılaştırarak bulunduğunda
yandaki hücreye, sayının bulunduğu sütunun en üzerindeki ismin(isimlerin) yazılması.

Örnek dosyada;

56 - çetin
73- mustafa, ümit vb.

Not: Elimdeki ham tabloda sütunlardaki sayılar değişken olup, can isimli sütunda 500 adet sayı varken,
bilal isimli sütunda 85023 adet sayı bulunabilmektedir.

Teşekkürler Şimdiden.

 

[Korhan Ayhan]

Merhaba,

Aşağıdaki kodu denermisiniz.

Option Explicit
 
Sub BUL_LİSTELE()
    Dim X As Long, BUL As Range, ADRES As String, SÜTUN As Byte
    
    Range("R2:R" & Rows.Count).ClearContents
    
    For X = 2 To Cells(Rows.Count, "Q").End(3).Row
        Set BUL = Range("A:O").Find(Cells(X, "Q"), , , xlWhole)
        If Not BUL Is Nothing Then
        ADRES = BUL.Address
        SÜTUN = BUL.Column
        Do
            If Cells(X, "R") = "" Then
                Cells(X, "R") = Cells(1, BUL.Column)
            Else
                Cells(X, "R") = Cells(X, "R") & ", " & Cells(1, BUL.Column)
            End If
        Set BUL = Range("A:O").FindNext(BUL)
        Loop While Not BUL Is Nothing And BUL.Address <> ADRES And BUL.Column <> SÜTUN
        End If
    Next
    
    Set BUL = Nothing
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[Necdet]

Merhaba,

Soru ile bende ilgilenmiştim, alternatif olsun.

Sub Bul()
    Dim Hucre   As Range, _
        SonSat  As Long, _
        Sat     As Long, _
        d
 
    SonSat = Range("A:O").Find("*", , , , xlByRows, xlPrevious).Row
    Sat = Cells(Rows.Count, "Q").End(3).Row + 1
 
    Application.ScreenUpdating = False
    Range("Q2:R" & Sat).ClearContents
    Sat = 0
 
    Set d = CreateObject("Scripting.Dictionary")
    For Each Hucre In Range("A2:O" & SonSat)
        If Not Hucre.Value = "" Then
            If d.exists(Hucre.Value) = False Then
                Sat = Sat + 1
                d.Add Hucre.Value, Cells(1, Hucre.Column)
            Else
                d.Item(Hucre.Value) = d.Item(Hucre.Value) & ", " & Cells(1, Hucre.Column)
            End If
        End If
    Next Hucre
    Range("Q2").Resize(Sat, 1) = Application.WorksheetFunction.Transpose(d.keys)
    Range("R2").Resize(Sat, 1) = Application.WorksheetFunction.Transpose(d.items)
 
End Sub

 

[ta2uk]

ustalar süpersiniz, aklınıza,emeğinize sağlık