tekrar eden verileri başlık haline getirerek aktarma

[peleryn]

özetle-dikey aktar

Herkese Merhabalar;


Ekli dosyamda özetle aşağıda belirttiğim probleme geniş bir çözüm arıyorum.

Ana sayfadaki listem şu olsun.
ali varlı | amaç 1 | |günlük yaşam
ali varlı | amaç 2 | |günlük yaşam
ali varlı | amaç 3 | |günlük yaşam
ali varlı | amaç 4 | |günlük yaşam
ali varlı | amaç 1 | |öz bakım
ali varlı | amaç 2 | |öz bakım
ali varlı | amaç 3 | |öz bakım
ali varlı | amaç 4 | |öz bakım
ali varlı | amaç 5 | |öz bakım

Aktarılacağı diğer bir sayfada bu listeyi şöyle özetletmek istiyorum.
ali varlı
günlük yaşam
amaç 1
amaç 2
amaç 3
amaç 4
öz bakım
amaç 1
amaç 2
amaç 3
amaç 4
amaç 5

Dosyada elimden geldiğince ayrıntılı açıklamasını da verdim.

Konuyla ilgilenecek olanlara şimdiden çok teşekkür ederim.

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodu PLANLAR(YATAY) isimli sayfanızın kod bölümüne uygulayıp denermisiniz.

Option Explicit
 
Private Sub Worksheet_Activate()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim X As Byte, İLK_SATIR As Long, SON_SATIR As Long
    Dim Y As Long, Satır As Long
    Dim MODÜL_İLK_SATIR As Long, MODÜL_SON_SATIR As Long
 
    Set S1 = Sheets("EĞİTİM PLANLARI")
    Set S2 = Sheets("PLANLAR(YATAY)")
 
    Application.ScreenUpdating = False
 
    S2.Range("B1:IV65536").Clear
 
    S1.Columns("B:B").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=S2.Range("B1"), Unique:=True
    S2.Range("B2:B" & S2.Range("B65536").End(3).Row).Copy
    S2.Range("B1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
    Range("A1").Select
    S2.Range("B2:B" & S2.Range("B65536").End(3).Row).Clear
    With S2.Range("B1:" & Cells(1, S2.Range("IV1").End(1).Column).Address)
        .Interior.ColorIndex = 1
        .Font.ColorIndex = 2
        .HorizontalAlignment = xlCenter
        .Font.Bold = True
    End With
 
    For X = 2 To S2.Range("IV1").End(1).Column
        İLK_SATIR = WorksheetFunction.Match(S2.Cells(1, X), S1.Range("B:B"), 0)
        SON_SATIR = WorksheetFunction.CountIf(S1.Range("B:B"), S2.Cells(1, X)) + İLK_SATIR - 1
        For Y = İLK_SATIR To SON_SATIR
            Satır = S2.Cells(65536, X).End(3).Row + 1
            S2.Cells(Satır, X) = S1.Cells(Y, "E")
            S2.Cells(Satır, X).Font.ColorIndex = 3
 
            MODÜL_İLK_SATIR = Evaluate("=MIN(IF('" & S1.Name & "'!B2:B65536='" & S2.Name & "'!" & Cells(1, X).Address & ",IF('" & S1.Name & "'!E2:E65536='" & S2.Name & "'!" & Cells(Satır, X).Address & ",ROW(2:65536))))")
            MODÜL_SON_SATIR = Evaluate("=MAX(IF('" & S1.Name & "'!B2:B65536='" & S2.Name & "'!" & Cells(1, X).Address & ",IF('" & S1.Name & "'!E2:E65536='" & S2.Name & "'!" & Cells(Satır, X).Address & ",ROW(2:65536))))")
 
            Satır = S2.Cells(65536, X).End(3).Row + 1
            S1.Range("C" & MODÜL_İLK_SATIR & ":C" & MODÜL_SON_SATIR).Copy S2.Cells(Satır, X)
 
            Y = MODÜL_SON_SATIR
        Next
    Next
 
    S2.Cells.CurrentRegion.Borders.LineStyle = 1
    S2.Cells.EntireColumn.AutoFit
 
    Set S1 = Nothing
    Set S2 = Nothing
 
    Application.ScreenUpdating = True
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[peleryn]

Korhan Hocam ellerinize sağlık.Tek kelimeyle harika olmuş.Çözümün yanı sıra görsel olarak ta ortaya çıkan sonuca gösterdiğiniz özene ayrıca teşekkür ederim.