Dönem Aktarma

[talatcd]

Selam Üstadlar; Ekte gönderdiğim çalışma kitabında açıklama yaptığım gibi DÖNEM sütununa göre diğer sayfada Satırlara AKTARMA yapacak, (En son dolu satırdan başlayacak.) Yıllık veriyi tutacağı için her listeyi ödeme yaparken işin sonunda dönemlere aktaracak. Allaha emanet olun.

 

[talatcd]

Sorumu anlatamadım herhalde arkadaşlar Sayfa1 de sayfa2 ye " Eşleşen dönemleri bulup aktaracak"

 

[mancubus]

pivot tablo tam da bunun için.

11 yıllık forum üyesinin bunu kolayca yapabileceğini tahmin ediyorum.

ben yine de dosya ekledim.

 

[veyselemre]

Sub duzenle()
    Dim aSon As Integer, lst1, w()

    Set sf1 = Sheets("Sayfa1")
    Set sf2 = Sheets("Sayfa2")

    With sf1
        aSon = .Cells(Rows.Count, "A").End(xlUp).Row
        lst1 = .Range(.Cells(2, "B"), .Cells(aSon, "F"))
        ReDim w(1 To aSon - 1, 1 To 17)
    End With

    Set dic = CreateObject("Scripting.Dictionary")
    For i = 4 To 16
        dic.Add sf2.Cells(1, i).Value, i
    Next i
    
    With CreateObject("Scripting.Dictionary")
        .CompareMode = vbTextCompare

        For i = 1 To UBound(lst1)
            Key = Trim(lst1(i, 2))

            If Not .Exists(Key) Then
                say = say + 1
                w(say, 1) = say
                w(say, 2) = lst1(i, 1)
                w(say, 3) = lst1(i, 2)
                .Add Key, say
            End If
            say = .Item(Key)
            sut = dic.Item(Trim(lst1(i, 3)))
            w(say, sut) = w(say, sut) + lst1(i, 5)
            w(say, 17) = w(say, 17) + lst1(i, 5)
            
        Next i
    End With

    sf2.Select
    Range("2:" & Rows.Count).Clear
    [a2].Resize(say, 17).Value = w

    Set sf1 = Nothing
    Set sf2 = Nothing
    Erase lst1, w
End Sub

 

[talatcd]

veyselemre Üstat Ellerine sağlık harikasın.