Hücre Birleştirme

[ozgurpeh]

Merhaba,

Ekli dosyada 3 sayfa göreceksiniz LİSTE kısmı sabit bir sayfa manuel giriş yapılıyor, istediğim işlem İSİM sayfasında hücrelere yazdığım format şeklinde giriş yapıldığı zaman SONUÇ kısmına isim sayfasında bulunan b sütünundaki değerlerin otomatik olarak aşağı liste şeklinde gelmesini istiyorum. Bu konuda yardımınızı rica ederim

 

[veyselemre]

Kodları İsim sayfasının kod kısmına ekleyin.

Dim dic As Object
Sub dicYukle()
    Set dic = CreateObject("Scripting.Dictionary")
    dic.comparemode = vbTextCompare
    veriler = Sheets("Liste").Range("A1:B" & Sheets("Liste").Cells(Rows.Count, 1).End(3).Row).Value
    For i = LBound(veriler) To UBound(veriler)
        dic(veriler(i, 1)) = veriler(i, 2)
    Next i
End Sub
Private Sub Worksheet_Activate()
    Call dicYukle
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, [a:A]) Is Nothing Then
        If dic Is Nothing Then dicYukle
        veriler = Range("A1:A" & Cells(Rows.Count, 1).End(3).Row).Value
        Sheets("Sonuç").Range("A:A").ClearContents
        For Each veri In IIf(IsArray(veriler), veriler, Array(veriler))
            For Each v In Split(veri, "-")
                If dic.exists(v) Then
                    sat = sat + 1
                    Sheets("Sonuç").Cells(sat, 1).Value = dic(v)
                End If
            Next v
        Next veri
    End If
End Sub

 

[ozgurpeh]

Kodları İsim sayfasının kod kısmına ekleyin.

Dim dic As Object
Sub dicYukle()
    Set dic = CreateObject("Scripting.Dictionary")
    dic.comparemode = vbTextCompare
    veriler = Sheets("Liste").Range("A1:B" & Sheets("Liste").Cells(Rows.Count, 1).End(3).Row).Value
    For i = LBound(veriler) To UBound(veriler)
        dic(veriler(i, 1)) = veriler(i, 2)
    Next i
End Sub
Private Sub Worksheet_Activate()
    Call dicYukle
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, [a:A]) Is Nothing Then
        If dic Is Nothing Then dicYukle
        veriler = Range("A1:A" & Cells(Rows.Count, 1).End(3).Row).Value
        Sheets("Sonuç").Range("A:A").ClearContents
        For Each veri In IIf(IsArray(veriler), veriler, Array(veriler))
            For Each v In Split(veri, "-")
                If dic.exists(v) Then
                    sat = sat + 1
                    Sheets("Sonuç").Cells(sat, 1).Value = dic(v)
                End If
            Next v
        Next veri
    End If
End Sub

Hata veriyor verdiğim örnek üzerinden bakabilirmisiniz. Sadece ahmet yazınca karşılığı olan 1925 gelsin Ahmet-Ali yazdığım zamanda sadece 2 sini sıralasın istiyorum 3 olunca 3 ünü gibi

 

[veyselemre]

Ekli dosyanız.