matris dönüşüm (indis - özet tablo)

[ferhatt]

arkadaşlar, 49*3 boyutunda bir matris var, birinci sütunda mamul, ikinci sütunda bileşenleri, üçüncü sütunda da bileşenlerin grupları var. bu matrisi farklı bir formata sokmak istiyorum: mamuller düşeyde her biri bir hücrede yazsın, her bir mamulün bulunduğu satırda da kendi grubu altında bileşenleri yazsın. Ekteki dosyaya baktığınızda daha kolay anlaşılacaktır. buradaki matris sadece örnek, dönüştüreceğim tabloda 60000den fazla satır var. Yardımcı olursanız çok sevinirim. İndis formülünü bilmiyorum, özet tablo ile de denedim ama tam bilmiyorum.

teşekkür ederim.

 

[Korhan Ayhan]

Selamlar,

Ekteki örnek dosyayı incelemisiniz. Listeleme Sayfa2 ye yapılmaktadır.

Uygulanan kod; (Boş bir modüle uygulayın.)

Option Explicit
 
Sub AKTAR()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim X As Long, SATIR As Range, SÜTUN As Byte
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Sayfa2")
    
    Application.ScreenUpdating = False
    
    S1.Columns("IS:IV").Delete
    S2.Range("A3:A65536,B2:IV65536").Clear
    
    S1.Range("A1:A65536").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=S1.Range("IS1"), Unique:=True
    S2.Range("A3:A" & S1.[IS65536].End(3).Row + 1).Value = S1.Range("IS2:IS" & S1.[IS65536].End(3).Row).Value
    S1.Range("A1:C65536").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=S1.Range("IT1"), Unique:=True
    S1.Columns("IT:IV").Sort Key1:=S1.Range("IV2"), Order1:=xlAscending, Key2:=S1.Range("IT2") _
    , Order2:=xlAscending, Key3:=S1.Range("IU2"), Order3:=xlAscending, Header _
    :=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom _
    , DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:=xlSortNormal
    
    For X = 2 To S1.[IT65536].End(3).Row
        Set SATIR = S2.[A:A].Find(S1.Cells(X, "IT"))
            If Not SATIR Is Nothing Then
    
                If WorksheetFunction.CountIf(S2.Rows(2), S1.Cells(X, "IV")) > 0 Then
                    SÜTUN = S2.Rows(2).Find(S1.Cells(X, "IV")).Column
                    If S2.Cells(SATIR.Row, SÜTUN) = Empty Then
                        S2.Cells(SATIR.Row, SÜTUN) = S1.Cells(X, "IU")
                        Else
                        SÜTUN = S2.Cells(SATIR.Row, "IV").End(1).Column + 1
                        S2.Cells(2, SÜTUN) = S1.Cells(X, "IV")
                        S2.Cells(SATIR.Row, SÜTUN) = S1.Cells(X, "IU")
                    End If
                
                Else
                
                    SÜTUN = S2.Cells(2, "IV").End(1).Column + 1
                    S2.Cells(2, SÜTUN) = S1.Cells(X, "IV")
                    S2.Cells(SATIR.Row, SÜTUN) = S1.Cells(X, "IU")
                End If
            End If
    Next
    
    S1.Columns("IS:IV").Delete
    S2.Select
    Set SATIR = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
    Application.ScreenUpdating = True
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub