Excel de bir sütuna ait değerleri yan yana yazmak.

[emeklikerem]

Arkadaşlar Merhaba;
Aşağıdaki kodda görüleceği üzere Excell de aynı sayfada farklı sütunlarda yer alan değerlerim var.

KROKI_NO	FORM_NO
3820	YT1703
3789	YT1703
3781	YT1703
3781	YT1703
3820	YT1703
3820	YT1703
3756	YT1703
3897	DP47
3897	DP47
3897	DP47
3897	DP47
3897	DP47
3897	DP47
3897	DP47
3897	DP47
3897	DP47
3897	DP47
3820	YT1703
3789	YT1703
3820	YT1703
3820	YT1703
3789	YT1703

Buraya 3. bir sütun açıp form no sütununu tekrar ettirmeden kapsadığı kroki numaralarını yan yana yazarak aşağıdaki görüntüyü elde etmek istiyorum. Bunun için nasıl bir formül kullanmam gerektiğini sizlere sormak isterim.

FORM_NO	YENİ SÜTUN
YT1703	3820/3789/3781/3756

Şimdiden teşekkür eder iyi günler dilerim.

 

[Ömer]

Merhaba,

Bu şekilde deneyin.

Daha önce makro kullanmadıysanız çalıştırmak için;
Linkte #4. mesajda konuyla ilgili açıklama yazmıştım.

http://www.excel.web.tr/f14/excelde-...a-t162312.html

Sub Ozet_Rapor()

    Dim d As Object, i As Long, deg, s

    Set d = CreateObject("Scripting.Dictionary")
    
    Application.ScreenUpdating = False
    
    For i = 2 To Cells(Rows.Count, "B").End(xlUp).Row
        deg = Cells(i, "B")
        If Not d.exists(deg) Then
            s = Cells(i, "A")
            d.Add deg, s
        Else
            s = d.Item(deg)
            s = s & "/" & Cells(i, "A")
            d.Item(deg) = s
        End If
    Next i

    Range("C2:D" & Rows.Count).ClearContents
            
    Range("C2").Resize(d.Count, 2) = _
        Application.Transpose(Array(d.keys, d.items))
        
    Application.ScreenUpdating = True

End Sub

.

 

[emeklikerem]

Ömer Bey;
İlginiz için çok teşekkür ederim. Verdiğiniz makro çalıştı ve çok heyecanlandım
fakat tekrarlı olmaması benim için önemli yukarıda verdiğim örnekteki gibi
YT1703 form numarası makronuz ile çalıştırdığımda

YT1703
 3820/3789/3781/3781/3820/3820/3756/3820/3789/3820/3820/3789

şeklinde geliyor.
Benim beklentim ise

YT1703	3820/3789/3781/3756

şeklinde kroki numaraları tekrar etmemesidir.
Geri dönüşünü bekler iyi günler dilerim.

 

[Ziynettin]

Merhaba,

Bu şekilde deneyiniz.

Option Explicit
Sub benzersiz_birlestir()
Dim a(), b(), c(), tbl(), d As Object,  d2 As Object
Dim deg As Variant, deg1 As Variant, s As Double, p As Byte
Dim i As Long, j As Byte, Say As Long

Application.ScreenUpdating = 0
s = TimeValue(Now)
With Sheets("Sayfa1")
    .Select
    Set d = CreateObject("scripting.dictionary")
    Set d2 = CreateObject("scripting.dictionary")
    a = .Range("A2:B" & .Cells(Rows.Count, 1).End(3).Row).Value
    
    ReDim b(1 To UBound(a), 1 To 3)
    For i = 1 To UBound(a)
        deg = a(i, 2)
        If Not d.exists(deg) Then
            Say = Say + 1
            d(deg) = Say
            b(Say, 1) = deg
        End If
        b(d(deg), 2) = b(d(deg), 2) & "|" & a(i, 1)
        b(d(deg), 3) = b(d(deg), 3) + 1
    Next i
    
    tbl = Array(b)
    
    Say = 0
    ReDim c(1 To d.Count, 1 To 2)
    For i = 1 To d.Count
        Say = Say + 1
        c(Say, 1) = tbl(0)(i, 1)
        deg = Split(tbl(0)(i, 2), "|")
        For j = 1 To UBound(deg)
            If Not d2.exists(deg(j)) Then
                p = p + 1
                d2(deg(j)) = p
                deg1 = deg1 & (deg(j)) & "/"
                c(Say, 2) = Left(deg1, Len(deg1) - 1)
            End If
        Next j
        deg1 = ""
    Next i
.Range("C2:D" & Rows.Count).ClearContents
.[C2].Resize(d.Count, 2) = c
.Range("C:D").EntireColumn.AutoFit
End With
Application.ScreenUpdating = 1
MsgBox "İşleminiz tamamlandı..." & vbLf & vbLf & _
    "       " & CDate(TimeValue(Now) - s), vbInformation
End Sub

https://www.dosyaupload.com/9fyQ

 

[emeklikerem]

Ziynettin Bey;
Tam olarak istediğim gibi oldu ilgi ve alakanız için teşekkür ederim.
İyi günler.