Excel de aynı verilerin yanyana sıralanması

[vtexcel]

Merhaba, arkadaşlar excel verilerimde aşağıda ki gibi bir işlem yapmak istiyorum. Bir formülü var mıdır.

Mevcut:

XX 01001 976411
XX 01001 980224
YY 01002 1128
YY 01002 1234

Yapmak İstediğim:

XX 01001 976411,980224
YY 01002 1128,1234

 

[vtexcel]

Bu arada 1. Sütun A, 2. Sütun B dir.

 

[çıtır]

Sorudan anladığım kadar ,örnekler A sütunda A1 hücresinden başladığı düşünüldü:Çözüm yardımcı sütun kullanılarak; C1 hücresine kopyalayınız ve çekerek çoğaltınız

=SOLDAN($A1;2)

B1 hücresine kopyalayıp çekerek çoğaltınız.

=EĞERHATA(EĞER(ESAYIYSA(EĞER(EĞERSAY($C$1:C1;C1)>1;KAÇINCI(C1;$C$1:C1;0)));DOLAYLI("A"&KAÇINCI(C1;$C$1:C1;0))&","&PARÇAAL(A1;BUL("*";YERİNEKOY(A1;" ";"*";2));UZUNLUK(A1));"");"")

 

[vtexcel]

Merhaba
Mevcut excel yapım şu şekilde;
Her stok Numarasını karşısında OEM numaraları yazıyor.
Bir stoka ait 3 eom var diğer stoğun da 2 oem numarası var.
https://hizliresim.com/g99Ppb

Amacım aşağıda ki gibi referans numaralarına göre OEM numaralarını yan sütunlarda açmak.

https://hizliresim.com/d77LNr

Sorudan anladığım kadar ,örnekler A sütunda A1 hücresinden başladığı düşünüldü:Çözüm yardımcı sütun kullanılarak; C1 hücresine kopyalayınız ve çekerek çoğaltınız

=SOLDAN($A1;2)

B1 hücresine kopyalayıp çekerek çoğaltınız.

=EĞERHATA(EĞER(ESAYIYSA(EĞER(EĞERSAY($C$1:C1;C1)>1;KAÇINCI(C1;$C$1:C1;0)));DOLAYLI("A"&KAÇINCI(C1;$C$1:C1;0))&","&PARÇAAL(A1;BUL("*";YERİNEKOY(A1;" ";"*";2));UZUNLUK(A1));"");"")

 

[çıtır]

İsteğiniz bu şekilede yanyana getirmek midir?
http://s6.dosya.tc/server11/5o8b3d/DAGITIM.rar.html

 

[vtexcel]

Merhaba, dosyam ektedir. Sizin verdiğiniz formülü uyguladım olmadı.

http://s6.dosya.tc/server11/4kgw4a/Kitap1.zip.html

 

[çıtır]

Merhaba, dosyam ektedir. Sizin verdiğiniz formülü uyguladım olmadı.

Dosyanızın 100000 satırdan fazla olduğunu belirtinde , çözüm üretmeye çalışan insanlarda ona göre çözüm üretsin ve ne yapamak istediğinizide resimden önce dosya ile gönderseydiniz çok daha güzel olurdu.İyi günler.

 

[Emir Hüseyin Çoban]

. . .

Dosyanız ektedir.
Ortalama işlem süresi 3-3.5 Dk...

Ekran Görüntüsü:

Sub KOD()
    Application.ScreenUpdating = False
    Dim SD As Worksheet: Set SD = Sheets("Sayfa1")
    Dim SO As Worksheet: Set SO = Sheets("Sayfa2")
    Dim liste(), dizi()

    son = SD.Cells(Rows.Count, "A").End(3).Row
    SD.Range("A2:B" & son).Sort SD.Range("A2"), xlAscending
    liste = SD.Range("A1:B" & son).Value
    Set dic = CreateObject("scripting.dictionary")

    For x = 1 To UBound(liste, 1)
        aranan = liste(x, 1)
        If Not dic.exists(aranan) Then
            dic.Add aranan, ""
        End If

    Next x

    SO.Cells.ClearContents
    SO.Range("A1").Resize(dic.Count, 1) = Application.Transpose(dic.keys)
    SO.Range("B1") = "Oem_No > > > "

    For i = 2 To SO.Cells(Rows.Count, "A").End(3).Row
        ilk = WorksheetFunction.Match(SO.Cells(i, "A"), SD.Range("A:A"), 0)
        son = WorksheetFunction.CountIf(SD.Range("A:A"), SO.Cells(i, "A")) + ilk - 1

        SD.Range("B" & ilk & ":B" & son).Copy
        SO.Cells(i, "B").PasteSpecial _
                Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=True, Transpose:=True

    Next i
    SO.Cells.EntireColumn.AutoFit
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    MsgBox " B i t t i"
End Sub

. . .

 

[Ziynettin]

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

 

[vtexcel]

Herkese çok teşekkür ederim. Ellerinize sağlık.

 

[Akincilar]

Merhaba,
Öncelikle teşekkürler. Ben de yapma istediğimi sizin sayenizde yapabildim. Ancak ben farklı olarak A sütünu ile B sütünu arasında 2 adet boş sütu bırakmak istiyorum. Yani yeni yazdırılan sayfada ilk bilgiler A sütununda olacak yan yana yazdırrılan bilgiler ise D sütunundan başlayacak. Kod içerisinde nerede değişiklik yapmam gerkeli. Şimdiden teşekkürler.

 

[Akincilar]

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,
Öncelikle teşekkürler. Ben de yapma istediğimi sizin sayenizde yapabildim. Ancak ben farklı olarak A sütünu ile B sütünu arasında 2 adet boş sütu bırakmak istiyorum. Yani yeni yazdırılan sayfada ilk bilgiler A sütununda olacak yan yana yazdırrılan bilgiler ise D sütunundan başlayacak. Kod içerisinde nerede değişiklik yapmam gerekli. Birde yan yana yazdırılan veriler text şeklinde geliyor. onları general olarak nasıl yazdırabilirim.Şimdiden teşekkürler.

 

[Korhan Ayhan]

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.Cells.Clear
   
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    Veri = S1.Range("A2:B" & Son).Value
   
    ReDim Liste(1 To Son, 1 To 4)
   
    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(Say, 1) = Veri(X, 1)
            Liste(Say, 4) = "|" & Veri(X, 2)
        Else
            Liste(Dizi.Item(Veri(X, 1)), 4) = Liste(Dizi.Item(Veri(X, 1)), 4) & "|" & Veri(X, 2)
        End If
    Next
   
    S2.Range("A2").Resize(Say, 4) = Liste
    S2.Range("D2").Resize(Say).TextToColumns Tab:=True, OtherChar:="|"
    S2.Columns(4).Delete
    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

 

[Akincilar]

Teşekkür ederim. Sağolun.

 

[tahsinanarat]

Sn.@korhan Ayhan hocam 13 de verdiğiniz kodda; Sayfa2 de A sutununda belirttiğimiz satırlardaki verileri Sayfa1 in A sutununda bulup B sutunundaki karşılıklarını birleştirmesini istersek, kodda nasıl bir değişiklik yapmalıyız. Teşekkürler.

 

[Korhan Ayhan]

Örnek dosya üzerinde tarif ederseniz alternatif çözüm önerebilirim.

 

[tahsinanarat]

Sn.@korhan Ayhan hocam 13 de verdiğiniz kodda; Sayfa2 de A sutununda belirttiğimiz satırlardaki verileri Sayfa1 in A sutununda bulup B sutunundaki karşılıklarını birleştirmesini istersek, kodda nasıl bir değişiklik yapmalıyız. Teşekkürler.

Sayfa2 nin A sutununda yazılı olanları Sayfa1 in B sutunu karşılıklarını örnek dosyada gösterdiğim şekilde D sutununda birleştirilmesini istiyorum.

örnek dosyam ekte

 

[Korhan Ayhan]

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

 

[tahsinanarat]

Sn. @Korhan Ayhan hocam çok teşekkür ediyorum, tam istediğim gibi oldu. Elinize sağlık.

 

[tahsinanarat]

Sn. @Korhan Ayhan Hocam Selamlar; bugün gerçek datalarla test ettiğimde Sayfa2 deki D sutunundaki birleştirmeler A sutunundaki bilginin aynı satırında değil de bir alt satırda birleştirdiğini fark ettim.