• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Excel de aynı verilerin yanyana sıralanması

  • Konbuyu başlatan Konbuyu başlatan vtexcel
  • Başlangıç tarihi Başlangıç tarihi
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;""))
 
Üstteki mesajımdaki kodda küçük bir düzeltme yaptım. Son halini deneyiniz.
 
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.
 

Ekli dosyalar

Son düzenleme:
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.
 
Sn. @Korhan Ayhan Hallettim, Teşekkürler.
Kod: 
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
 
Ziynettin' Alıntı:
Alternatif;

Kod: 
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
Genişletmek için tıkla ...

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?
 
İşyerinde kullandığınız işletim sistemi ve ofis sürümü nedir?
 
Çalışmaması için bir sebep görünmüyor.

Peki kodu çalıştırınca hangi satırda hata oluşuyor?
 
Bunu nasıl kullanacağım. Sadece sayfa1 sayfam var ve veriler A B sütününda
Korhan Ayhan' Alıntı:
Deneyiniz.

C++: 
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
Genişletmek için tıkla ...
 
Sayfa2'yi kendiniz ekleyip deneyebilirsiniz.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst