Aylara göre borç dağılımın yapılması(Otomatik)

[starmetin]

Selam arkadaşlar bu siteden edindiğim bilgiler ve yardımlarınız çalışmış olduğum iş yerinde büyük faydasını görmüş bulunmaktayım.Bu siteye ve bu konularda yardımcı olan herkese ayrı ayrı Teşekkürlerimi sunarım.Bir konuda yine yardımlarınıza ihtiyacım var.

Yapmak istediğimi Ekli dosyada anlatmaya çalıştım.

Kısaca :5 sayfadan oluşan bir dosya.

1.sayfada Ayrıntılı tahsilat listesi (Firmalara kesilen faturalar , farklı tarihlerde olabilir.)
2-3-4-5 sayfada bu firmaların grulandırması bölümlere göre dağılımı.

1. sayfada ayrıntılı tahsilat listesi sayfasında yer alan kesilen faturaların aylara göre bu grublandırılmış sayfalardaki ilgili sütunlara (aylara) otomatik olarak aktarılmasını yapmaya çalışıyorum

İlgi ve yardımlarınız için şimdiden çok teşekkürler.


Hürmetler..

 

[veyselemre]

Kodu deneyin.

Sub aylikBakiyeleriIlgiliFirmalaraAktar()
    Application.ScreenUpdating = False
    Dim yeni(0 To 2)
    Dim ayToplam(1 To 12)
    sayfalar = Array("Temizlik", "Ortak", "Personel", "Güvenlik")

    With CreateObject("scripting.dictionary")
        .CompareMode = TextCompare
        For x = 0 To 3
            Sheets(sayfalar(x)).Select
            son = [B65536].End(3).Row
            For t = 3 To 25 Step 2
                Range(Cells(6, t), Cells(son, t)).ClearContents
            Next t
            a = Range("B6:B" & son)
            For i = 1 To UBound(a, 1)
                firma = a(i, 1)
                If Not .Exists(firma) Then
                    yeni(0) = x
                    yeni(1) = i + 5
                    yeni(2) = ayToplam
                    .Add firma, yeni
                End If
            Next i
        Next x

        Sheets("Ayrıntılı Tahsilat").Select
        Range("A2:C" & [A65536].End(3).Row).Font.Bold = False
        a = Range("A2:C" & [A65536].End(3).Row)

        For i = 1 To UBound(a, 1)
            firma = a(i, 1)
            If Not .Exists(firma) Then
                Range("A" & i + 1 & ":C" & i + 1).Font.Bold = True
                yazilmayan = yazilmayan + CDbl(a(i, 3))
            Else
                ay = Month(a(i, 2))
                yil = Year(a(i, 2))
                If yil = 2009 Then
                    ay = ay + 12
                End If
                ay = ay - 9
                If ay > 0 And ay < 13 Then
                    al = .Item(firma)
                    Top = al(2)
                    Top(ay) = CDbl(Top(ay)) + CDbl(a(i, 3))
                    al(2) = Top
                    .Item(firma) = al
                Else
                    Range("B" & i + 1 & ":C" & i + 1).Font.Bold = True
                    yazilmayan = yazilmayan + CDbl(a(i, 3))
                End If

            End If
        Next i

        y = .items
        For x = LBound(y) To UBound(y)
            sayfa = y(x)(0)
            sira = y(x)(1)
            toplamlar = y(x)(2)
            For i = 1 To 12
                If Not IsEmpty(toplamlar(i)) Then
                    Sheets(sayfalar(sayfa)).Cells(sira, (i * 2) + 1) = toplamlar(i)
                End If
            Next i
        Next x

    End With
    MsgBox "İlgili Sayfalara Aktarılmayan Tutar Toplamı : " & Format(yazilmayan, "#,##0.00")
End Sub

 

[starmetin]

Sn.veyselemre ilgi ve yardımlarınız için çok çok teşekkürler.
Yazdığınız macro çok güzel çalışıyor.
yalnız bir şey daha yapabilmek mümkünmüdür verileri aktarmadan önce daha önce girilmiş olan sütunlarıdaki bilgileri silip tekrardan aktarım yapabilmesi bilmesi mümkünmüdür (çünkü manuel olarak elle girilmiş tutarlarda olabiliyor sonradan) , eğer bu işlem zor der iseniz aktarım yapmadan önce manuel olarak ellede silebilirim çok sorun yaratmaz hani kolay yöntemi varsa diye soruyorum.

ilgili macro 4 sayfa üzerinde çalışıyor yeni bir sayfa daha eklersem 5 ve ya 6... sayfa gibi ilgili macroda ne gibi değişiklik yapmam gerekiyor.

İlgi ve yardımlarınız için çok teşekkürler ederim elleriniz dert görmesin.

Hürmetler.

 

[veyselemre]

Düzenlenmiş kodları inceleyiniz.

Sub aylikBakiyeleriIlgiliFirmalaraAktar()
    Application.ScreenUpdating = False
    Dim yeni(0 To 2)
    Dim ayToplam(1 To 12)
    sayfalar = Array("Temizlik", "Ortak", "Personel", "Güvenlik") ' Yeni sayfaları buraya ekleyebilirsiniz.

    With CreateObject("scripting.dictionary")
        .CompareMode = TextCompare
        For x = 0 To UBound(sayfalar)
            Sheets(sayfalar(x)).Select
            son = [B65536].End(3).Row
            For t = 3 To 25 Step 2
                Range(Cells(6, t), Cells(son, t)).ClearContents
            Next t
            a = Range("B6:B" & son)
            For i = 1 To UBound(a, 1)
                firma = a(i, 1)
                If Not .Exists(firma) Then
                    yeni(0) = x
                    yeni(1) = i + 5
                    yeni(2) = ayToplam
                    .Add firma, yeni
                End If
            Next i
        Next x

        Sheets("Ayrıntılı Tahsilat").Select
        Range("A2:C" & [A65536].End(3).Row).Font.Bold = False
        a = Range("A2:C" & [A65536].End(3).Row)

        For i = 1 To UBound(a, 1)
            firma = a(i, 1)
            If Not .Exists(firma) Then
                Range("A" & i + 1 & ":C" & i + 1).Font.Bold = True
                yazilmayan = yazilmayan + CDbl(a(i, 3))
            Else
                ay = Month(a(i, 2))
                yil = Year(a(i, 2))
                If yil = 2009 Then
                    ay = ay + 12
                End If
                ay = ay - 9
                If ay > 0 And ay < 13 Then
                    al = .Item(firma)
                    Top = al(2)
                    Top(ay) = CDbl(Top(ay)) + CDbl(a(i, 3))
                    al(2) = Top
                    .Item(firma) = al
                Else
                    Range("B" & i + 1 & ":C" & i + 1).Font.Bold = True
                    yazilmayan = yazilmayan + CDbl(a(i, 3))
                End If

            End If
        Next i

        y = .items
        For x = LBound(y) To UBound(y)
            sayfa = y(x)(0)
            sira = y(x)(1)
            toplamlar = y(x)(2)
            For i = 1 To 12
                If Not IsEmpty(toplamlar(i)) Then
                    Sheets(sayfalar(sayfa)).Cells(sira, (i * 2) + 1) = toplamlar(i)
                End If
            Next i
        Next x

    End With
    MsgBox "İlgili Sayfalara Aktarılmayan Tutar Toplamı : " & Format(yazilmayan, "#,##0.00")
End Sub

 

[starmetin]

Sn: veyselemre çok çok teşekkürler şu an için her şey istediğim gibi , ilgi ve paylaşımlarınız için tekrar çok teşekkürler.Elleriniz dert görmesin.

Hürmetler.