Aynı verileri bulup aynı olanları yan yana taşıma

[yosun09]

Merhabalar excel de 4 sütun var. ilk resimdeki gibi.


Bunlardan ilk sütuna bakarak aynı olanları ilk aynı olanın yanına taşıması gerekiyor. Sonuçta 2 resimdeki gibi olması gerekiyor.

Bir türlü beceremedim. Yardımcı olabilir misiniz lütfen. macrolarda da çok yeniyim.

 

[Korhan Ayhan]

Merhaba,

Verilerinizi yedekleyerek deneyiniz.

Option Explicit

Sub Yan_Yana_Aktar()
    Dim Dizi As Object, Veri As Variant
    Dim X As Long, Y As Integer, Sutun_Veri As Byte
    Dim Sutun_Dizi As Variant, Max_Sutun As Integer
    Dim Say As Long, Zaman As Double
    
    Zaman = Timer
    
    Set Dizi = VBA.CreateObject("Scripting.Dictionary")
    
    Veri = Range("A1").CurrentRegion.Value
    
    ReDim Liste(1 To UBound(Veri, 1), 1 To 16384)
    
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        Sutun_Veri = 1
        If Not Dizi.Exists(Veri(X, 1)) Then
            Say = Say + 1
            Dizi.Add Veri(X, 1), Array(Say, 1)
            For Y = 1 To 4
                Liste(Say, Y) = Veri(X, Sutun_Veri)
                Sutun_Veri = Sutun_Veri + 1
            Next
            Sutun_Dizi = Dizi.Item(Veri(X, 1))
            Sutun_Dizi(1) = Y
            Max_Sutun = Application.Max(Max_Sutun, Sutun_Dizi(1))
            Dizi.Item(Veri(X, 1)) = Sutun_Dizi
        Else
            For Y = Dizi.Item(Veri(X, 1))(1) To Dizi.Item(Veri(X, 1))(1) + 3
                Liste(Dizi.Item(Veri(X, 1))(0), Y) = Veri(X, Sutun_Veri)
                Sutun_Veri = Sutun_Veri + 1
            Next
            Sutun_Dizi = Dizi.Item(Veri(X, 1))
            Sutun_Dizi(1) = Y
            Max_Sutun = Application.Max(Max_Sutun, Sutun_Dizi(1))
            Dizi.Item(Veri(X, 1)) = Sutun_Dizi
        End If
    Next
    
    If Say > 0 Then
        Cells.Delete
        Range("A1").Resize(Say, Max_Sutun) = Liste
        Columns.AutoFit
        MsgBox "İşleminiz tamamlanmıştır." & vbCrLf & vbCrLf & _
               "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
    End If

    Dizi.RemoveAll
    Erase Liste
    Set Dizi = Nothing
End Sub

 

[yosun09]

Çok teşekkür ederim. Mükemmel bir şekilde çalıştı.