Excel de aynı verilerin yanyana sıralanması

[YUSUF44]

Korhan Bey'in izniyle eğer Ofis 365 kullanıyorsanız D3 hücresinde aşağıdaki formül istediğiniz sonucu veriyor:

=METİNBİRLEŞTİR("|";DOĞRU;FİLTRE(Sayfa1!$B$2:$B$57;Sayfa1!$A$2:$A$57=A3;""))

 

[Korhan Ayhan]

Üstteki mesajımdaki kodda küçük bir düzeltme yaptım. Son halini deneyiniz.

 

[tahsinanarat]

Sn. @Korhan Ayhan Hocam elinize sağlık şimdi oldu, Çok teşekkür ediyorum.
Hocam eğer çok vaktinizi almayacaksa bir şey daha sormak istiyorum. Sayfa2 nin A sutunundaki isimleri Sayfa1 in B sutunundaki isimler ile (Sayfa1 de A sutunda Sicil, B sutununda İsim) karşılaştırıp Sayfa1 deki A sutununda bulunan Sicilleri birleştirmek istersek, kodda nasıl bir değişiklik yapmalıyız.

 

[Korhan Ayhan]

Kod içindeki ilk X döngüsündeki Veri(X, 1) yazanları Veri(X, 2) yapın. Aynı şekilde Veri(X, 2) olanların Veri(X, 1) yapın. Yani sütunları yer değiştirin.

 

[tahsinanarat]

Sn. @Korhan Ayhan Hallettim, Teşekkürler.

Option Explicit

Sub Analiz()
    Dim S1 As Worksheet, S2 As Worksheet, Dizi As Object, Say As Long
    Dim Veri As Variant, Son As Long, X As Long, Zaman As Double

    Application.ScreenUpdating = False

    Zaman = Timer

    Set S1 = Sheets("Mukerrer")
    Set S2 = Sheets("SB_Arama")
    Set Dizi = CreateObject("Scripting.Dictionary")

    S2.Range("k:k").Clear

    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    Veri = S1.Range("A2:B" & Son).Value

    ReDim Liste_A(1 To Son, 1 To 1)

    For X = LBound(Veri) To UBound(Veri)
        If Not Dizi.Exists(Veri(X, 2)) Then
            Say = Say + 1
            Dizi.Add Veri(X, 2), Say
            Liste_A(Say, 1) = "" & Veri(X, 1)
        Else
            Liste_A(Dizi.Item(Veri(X, 2)), 1) = Liste_A(Dizi.Item(Veri(X, 2)), 1) & "-" & Veri(X, 1)
        End If
    Next

    Son = S2.Cells(S2.Rows.Count, 1).End(3).Row
    Veri = S2.Range("A2:A" & Son).Value

    ReDim Liste_B(1 To Son, 1 To 1)
  
    For X = LBound(Veri) To UBound(Veri)
        If Dizi.Exists(Veri(X, 1)) Then
            Liste_B(X, 1) = Liste_A(Dizi.Item(Veri(X, 1)), 1)
        Else
            Liste_B(X, 1) = ""
        End If
    Next

    S2.Range("k2").Resize(Son) = Liste_B
    S2.Cells.HorizontalAlignment = xlLeft
    S2.Columns.AutoFit

    Set S1 = Nothing
    Set S2 = Nothing
    Set Dizi = Nothing

    Application.ScreenUpdating = True

'    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
'           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

 

[alpusta]

Alternatif;

Option Explicit
Sub yan_sutunlara()
Dim a(), b(), c(), tbl(), d As Object, d1 As Object, deg As Variant
Dim i As Long, j As Byte, Say As Long, Sut_Liste(), Sut As Byte, s As Double
Sheets("Sayfa1").Activate
Application.ScreenUpdating = 0
s = TimeValue(Now)

Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
a = Range("A2:B" & Cells(Rows.Count, 1).End(3).Row)

ReDim b(1 To UBound(a), 1 To 3)
    For i = 1 To UBound(a)
        If Not d.exists(a(i, 1)) Then
            Say = Say + 1
            d(a(i, 1)) = Say
            b(Say, 1) = a(i, 1)
        End If
        b(d(a(i, 1)), 2) = b(d(a(i, 1)), 2) & "|" & a(i, 2)
        b(d(a(i, 1)), 3) = b(d(a(i, 1)), 3) + 1
    Next i
   
tbl = Array(b)
    For i = 1 To d.Count
    deg = (tbl(0)(i, 3))
        If Not d1.exists(deg) Then
            d1(deg) = tbl(0)(i, 3)
        End If
    Next i
Sut_Liste = d1.keys
Sut = Application.Max(Sut_Liste)
ReDim c(1 To d.Count, 1 To Sut + 1)
Say = 0
    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)
            c(Say, j + 1) = deg(j)
        Next j
    Next i
With Sheets("Sayfa2")
.Cells.ClearContents
.[A2].Resize(d.Count, Sut + 1).NumberFormat = "@"
.[A2].Resize(d.Count, Sut + 1) = c
.Cells.EntireColumn.AutoFit
.Select
End With
Application.ScreenUpdating = 1
MsgBox "İşleminiz tamamlandı..." & vbLf & vbLf & _
    CDate(TimeValue(Now) - s), vbInformation
End Sub

http://www.dosya.tc/server10/56ak7e/Kitap1-1.rar.html

Merhaba @Ziynettin hocam, verdiğiniz kodu ekledim evde çalışıyor ama isyerinde "object doesn't support property or method" şeklinde hata mesajı alıyorum. Bu sorunu nasıl çözebilirim?

 

[Korhan Ayhan]

İşyerinde kullandığınız işletim sistemi ve ofis sürümü nedir?

 

[alpusta]

İşyerinde kullandığınız işletim sistemi ve ofis sürümü nedir?

Office profesyonel plus 2019 her iki taraf
Windows 10 iş - Windows 7 ev

 

[Korhan Ayhan]

Çalışmaması için bir sebep görünmüyor.

Peki kodu çalıştırınca hangi satırda hata oluşuyor?

 

[ruzzher]

Bunu nasıl kullanacağım. Sadece sayfa1 sayfam var ve veriler A B sütününda

Deneyiniz.

Option Explicit

Sub Analiz()
    Dim S1 As Worksheet, S2 As Worksheet, Dizi As Object, Say As Long
    Dim Veri As Variant, Son As Long, X As Long, Zaman As Double

    Application.ScreenUpdating = False

    Zaman = Timer

    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Sayfa2")
    Set Dizi = CreateObject("Scripting.Dictionary")

    S2.Range("D:D").Clear

    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    Veri = S1.Range("A2:B" & Son).Value

    ReDim Liste_A(1 To Son, 1 To 1)

    For X = LBound(Veri) To UBound(Veri)
        If Not Dizi.Exists(Veri(X, 1)) Then
            Say = Say + 1
            Dizi.Add Veri(X, 1), Say
            Liste_A(Say, 1) = "|" & Veri(X, 2)
        Else
            Liste_A(Dizi.Item(Veri(X, 1)), 1) = Liste_A(Dizi.Item(Veri(X, 1)), 1) & "|" & Veri(X, 2)
        End If
    Next

    Son = S2.Cells(S2.Rows.Count, 1).End(3).Row
    Veri = S2.Range("A2:A" & Son).Value

    ReDim Liste_B(1 To Son, 1 To 1)
  
    For X = LBound(Veri) To UBound(Veri)
        If Dizi.Exists(Veri(X, 1)) Then
            Liste_B(X, 1) = Liste_A(Dizi.Item(Veri(X, 1)), 1)
        Else
            Liste_B(X, 1) = "Bulunamadı!"
        End If
    Next

    S2.Range("D2").Resize(Son) = Liste_B
    S2.Cells.HorizontalAlignment = xlLeft
    S2.Columns.AutoFit

    Set S1 = Nothing
    Set S2 = Nothing
    Set Dizi = Nothing

    Application.ScreenUpdating = True

    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

 

[Korhan Ayhan]

Sayfa2'yi kendiniz ekleyip deneyebilirsiniz.