Alt alta sıralanan kodların sütunlara dağıtılması

[semih.gursoy]

Merhaba ,
Ekteki dosyada yer alan bir koda ait bilgileri sutunlara paylaştırmak istiyorum.Dosyada istediğim formatı özet sayfasına bir kod için yansıttım.
Bu konuda yardımcı olacak arkadaşlara şimdiden tşkler.

 

[semih.gursoy]

Merhaba ,
Bu konuda yardımcı olabilecek arkadaş var mı

 

[semih.gursoy]

Merhaba ,
Bu konuda yardımcı olabilecek arkadaş var mı

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Analiz()
    Dim S1 As Worksheet, S2 As Worksheet, Dizi_A As Object, Dizi_B As Object
    Dim Veri As Variant, X As Long, Aranan As String, Say As Long, Son As Long
    Dim WF As WorksheetFunction, Dizi_Item, Y As Integer, Zaman As Double
    
    Zaman = Timer
    
    Application.ScreenUpdating = False
    
    Set S1 = Sheets("DATA")
    Set S2 = Sheets("ÖZET")
    Set WF = WorksheetFunction
    Set Dizi_A = CreateObject("Scripting.Dictionary")
    Set Dizi_B = CreateObject("Scripting.Dictionary")
    
    S2.Cells.Clear
    
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    If Son = 2 Then Son = 3
    
    S1.Range("I2") = 1
    S1.Range("I2").AutoFill Destination:=S1.Range("I2:I" & Son), Type:=xlFillSeries
    S1.Range("A2:I" & Son).Sort S1.Range("H2"), xlAscending
    
    Veri = S1.Range("A2:H" & Son).Value
    
    S1.Range("A2:I" & Son).Sort S1.Range("I2"), xlAscending
    S1.Range("I:I").ClearContents
    
    For X = LBound(Veri) To UBound(Veri)
        Aranan = Veri(X, 2) & "|" & Veri(X, 8)
        If Not Dizi_A.Exists(Aranan) Then
            Dizi_A.Add Aranan, 1
        Else
            Dizi_A.Item(Aranan) = Dizi_A.Item(Aranan) + 1
        End If
    Next
        
    
    For X = LBound(Veri) To UBound(Veri)
        Aranan = Veri(X, 2) & "|" & Veri(X, 8)
        If Not Dizi_B.Exists(Split(Aranan, "|")(1)) Then
            Dizi_B.Add Split(Aranan, "|")(1), Dizi_A.Item(Aranan)
        Else
            Dizi_B.Item(Split(Aranan, "|")(1)) = WF.Max(Dizi_B.Item(Split(Aranan, "|")(1)), Dizi_A.Item(Aranan))
        End If
    Next
    
    ReDim Sutun_Basliklari(1 To 1)
    
    For Each Dizi_Item In Dizi_B.Keys
        For X = 1 To Dizi_B.Item(Dizi_Item)
            Say = Say + 1
            ReDim Preserve Sutun_Basliklari(1 To Say)
            Sutun_Basliklari(Say) = Dizi_Item
        Next
    Next
    
    ReDim Liste(1 To Son, 1 To Say + 2)
    
    Dizi_A.RemoveAll
    Say = 0
    
    For X = LBound(Veri) To UBound(Veri)
        Aranan = Veri(X, 4) & "|" & Veri(X, 8)
        If Not Dizi_A.Exists(Veri(X, 2)) Then
            Say = Say + 1
            Dizi_A.Add Veri(X, 2), Say
            Liste(Say, 1) = Veri(X, 2)
            Liste(Say, 2) = Veri(X, 3)
            For Y = LBound(Sutun_Basliklari) To UBound(Sutun_Basliklari)
                If Sutun_Basliklari(Y) = Veri(X, 8) Then
                    If Liste(Say, Y + 2) = "" Then
                        Liste(Say, Y + 2) = Veri(X, 4)
                        Exit For
                    End If
                End If
            Next
        Else
            For Y = LBound(Sutun_Basliklari) To UBound(Sutun_Basliklari)
                If Sutun_Basliklari(Y) = Veri(X, 8) Then
                    If Liste(Dizi_A.Item(Veri(X, 2)), Y + 2) = "" Then
                        Liste(Dizi_A.Item(Veri(X, 2)), Y + 2) = Veri(X, 4)
                        Exit For
                    End If
                End If
            Next
        End If
    Next
    
    If Say > 0 Then
        S2.Range("A1:B1") = Array("Malzeme Kodu", "Malzeme Adı")
        S2.Range("C1").Resize(1, UBound(Sutun_Basliklari)) = Sutun_Basliklari
        S2.Range("A1").Resize(1, UBound(Sutun_Basliklari) + 2).Font.Bold = True
        S2.Range("A1").Resize(1, UBound(Sutun_Basliklari) + 2).HorizontalAlignment = xlCenter
        S2.Range("A2").Resize(Say, UBound(Liste, 2)) = Liste
        S2.Columns.AutoFit
        S2.Select
    End If
    
    Set S1 = Nothing
    Set S2 = Nothing
    Set WF = Nothing
    Set Dizi_A = Nothing
    Set Dizi_B = Nothing
    
    Application.ScreenUpdating = True
    
    MsgBox "Veri aktarımı tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

 

[veyselemre]

Option Explicit
Sub ozetle()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim Veri, bul, itms, kys, ver
    Dim Son As Long, i As Long, ii As Long
    Dim al As String, mx As Integer, uz As Integer, Say As Integer
    Set S2 = Sheets("ozet")

    Application.ScreenUpdating = False

    Sheets("Data").Copy Sheets("Data")
    Set S1 = ActiveSheet

    Range("A:A,E:G").Delete

    [a1].CurrentRegion.Sort [d1], , [a1], , , , , xlYes

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

    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(Veri)
            al = Veri(i, 4) & "|" & Veri(i, 1)
            .Item(al) = .Item(al) + 1
        Next i

        itms = .items
        kys = .Keys

        .RemoveAll

        For i = LBound(itms) To UBound(itms)
            al = Split(kys(i), "|")(0)
            If .Exists(al) Then
                mx = .Item(al)
                If mx < itms(i) Then .Item(al) = itms(i)
            Else
                .Item(al) = itms(i)
            End If
        Next i

        itms = .items
        kys = .Keys

        uz = WorksheetFunction.Sum(itms)
        Dim baslik
        ReDim baslik(1 To 1, 1 To uz)
        For i = LBound(itms) To UBound(itms)
            For ii = 1 To itms(i)
                Say = Say + 1
                baslik(1, Say) = kys(i)
            Next ii
        Next i

        S2.Select

        Cells.ClearContents
        Range("C1").Resize(1, uz).Value = baslik
        S1.Select

        [a1].CurrentRegion.Sort [a1], , [d1], , , , , xlYes
        Veri = Range("A2:D" & Son).Value
        .RemoveAll

        For i = 1 To UBound(Veri)
            .Item(Veri(i, 1)) = Veri(i, 2)
        Next i

        S2.Select

        itms = .items
        kys = .Keys
        For i = LBound(itms) To UBound(itms)
            Cells(i + 2, 1) = kys(i)
            Cells(i + 2, 2) = itms(i)
        Next i
        .RemoveAll

        For i = 2 To Cells(Rows.Count, 1).End(3).Row
            For ii = 3 To Cells(1, Columns.Count).End(1).Column
                al = Cells(i, 1) & "|" & Cells(1, ii)
                If .Exists(al) Then
                    ver = .Item(al)
                    ver = ver & "," & Cells(i, ii).Address
                    .Item(al) = ver
                Else
                    ver = "," & Cells(i, ii).Address
                    .Item(al) = ver
                End If
            Next ii
        Next i

        For i = 1 To UBound(Veri)
            al = Veri(i, 1) & "|" & Veri(i, 4)
            bul = Split(.Item(al), ",")
            For ii = LBound(bul) To UBound(bul)
                If bul(ii) <> "" Then
                    Range(bul(ii)) = Veri(i, 3)
                    bul(ii) = ""
                    .Item(al) = Join(bul, ",")
                    Exit For
                End If
            Next ii
        Next i
    End With
    
    S2.Range("A1:B1") = Array("Malzeme Kodu", "Malzeme Adı")
    S2.Range("A1").Resize(1, uz + 2).Font.Bold = True
    S2.Range("A1").Resize(1, uz + 2).HorizontalAlignment = xlCenter
    S2.Columns.AutoFit

    Application.DisplayAlerts = False
    S1.Delete
    Application.DisplayAlerts = True

End Sub

 

[semih.gursoy]

Korhan Bey çok tşkler elinize sağlık.

 

[semih.gursoy]

Veysel Bey çok tşkler elinize sağlık.