ödeme tablosu ayırma

[samedgunduz]

Merhabalar,

haftalık müşterilere çıkarttığımız ödeme tablomuz var.
örneğin 1 milyon 500 bin lira ödeme çıkartıyoruz.
İmza yetkisi 100.000 bin olduğu için müşterileri 15 sayfaya 100 er bin lira denk gelecek şekilde tek tek ayırıyoruz.
bunu formül ile otomatik yapma şansımız var mı? ( 100 bini geçmeyecek ama sayfalardaki müşteriler toplam 96.000 , 98.000 olabilir maximum 100.000 olacak. )

örneğin :

a firmasına : 15.000 tl
b firmasına : 3.800 tl
c firmasına : 36.000 tl
d firması : 22.000 tl
e firması : 21.000 tl
bunları bir sayfada diğerlerini de bunun gibi 100.000 tl yi geçmeyecek şekilde ayırsın.

 

[samedgunduz]

ÖRNEK DOSYA
ÖRNEK.xlsx - 12 KB

 

[YUSUF44]

Öncelikle sayfa2'yi yazdırma ayarlarından bir sayfaya sığacak şekilde ayarlayın. Daha sonra aşağıdaki makroyu bir modüle kopyalayın. Makroyu çalıştırdığınızda listenizi istediğiniz gibi 100 bin lirayı geçmeyecek şekilde parçalara böler ve oluşan tabloyu o günkü tarihle pdf dosyası olarak kaydeder:

Sub paralar()
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
son = s1.Cells(Rows.Count, "A").End(3).Row
s2.[A2:C13].ClearContents
s1.Range("D2:D" & son).ClearContents
s1.Range("A2:D" & son).Interior.Color = xlNone
a = 1
For i = 2 To son
    If s2.Cells(i, "D") <> "Aktarıldı" Then
        If s2.Cells(i, "C") > 100000 Then
            s1.Cells(i, "D") = "Limit Üstü"
            s1.Range("A" & i & ":D" & i).Interior.Color = vbRed
        ElseIf s2.[A13] <> "" Or s2.[C14] + s1.Cells(i, "C") > 100000 Then
            s2.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
            Format(Date, "DDMMYYYY") & " " & Format(a, "00") & ".pdf", Quality:=xlQualityStandard, _
            IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
            a = a + 1
            s2.[A2:C13].ClearContents
            s2.[A2] = s1.Cells(i, "A")
            s2.[B2] = s1.Cells(i, "B")
            s2.[C2] = s1.Cells(i, "C")
            s1.Cells(i, "D") = "Aktarıldı"
            s1.Range("A" & i & ":D" & i).Interior.Color = vbGreen
        Else
            Set c = s2.[A1:A13].Find("")
            If Not c Is Nothing Then
                c.Offset(0, 0) = s1.Cells(i, "A")
                c.Offset(0, 1) = s1.Cells(i, "B")
                c.Offset(0, 2) = s1.Cells(i, "C")
                s1.Cells(i, "D") = "Aktarıldı"
                s1.Range("A" & i & ":D" & i).Interior.Color = vbGreen
            End If
        End If
    End If
    If i = son Then
        s2.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
        Format(Date, "DDMMYYYY") & Format(a, "00") & ".pdf", Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
    End If
Next
End Sub

 

[samedgunduz]

Öncelikle sayfa2'yi yazdırma ayarlarından bir sayfaya sığacak şekilde ayarlayın. Daha sonra aşağıdaki makroyu bir modüle kopyalayın. Makroyu çalıştırdığınızda listenizi istediğiniz gibi 100 bin lirayı geçmeyecek şekilde parçalara böler ve oluşan tabloyu o günkü tarihle pdf dosyası olarak kaydeder:

Hocam eline sağlık çok güzel çalışma olmuş.
Peki bunu excelde sayfalara ayırma şansımız var mı?
çünkü excel dosyası olarak bankaya mail atıyoruz.

 

[YUSUF44]

Konuyu unutmuşum, gecikme için kusura bakmayın.

Excel dosyası yapmak için aşağıdaki makroları bir modüle kopyalayın ve paralarXLSX makrosunu çalıştırın:

Sub paralarXLSX()
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
son = s1.Cells(Rows.Count, "A").End(3).Row
s2.[A2:C13].ClearContents
s1.Range("D2:D" & son).ClearContents
s1.Range("A2:D" & son).Interior.Color = xlNone
a = 1
For i = 2 To son
    If s2.Cells(i, "D") <> "Aktarıldı" Then
        If s2.Cells(i, "C") > 100000 Then
            s1.Cells(i, "D") = "Limit Üstü"
            s1.Range("A" & i & ":D" & i).Interior.Color = vbRed
        ElseIf s2.[A13] <> "" Or s2.[C14] + s1.Cells(i, "C") > 100000 Then
            Call xlsxyap
            a = a + 1
            s2.[A2:C13].ClearContents
            s2.[A2] = s1.Cells(i, "A")
            s2.[B2] = s1.Cells(i, "B")
            s2.[C2] = s1.Cells(i, "C")
            s1.Cells(i, "D") = "Aktarıldı"
            s1.Range("A" & i & ":D" & i).Interior.Color = vbGreen
        Else
            Set c = s2.[A1:A13].Find("")
            If Not c Is Nothing Then
                c.Offset(0, 0) = s1.Cells(i, "A")
                c.Offset(0, 1) = s1.Cells(i, "B")
                c.Offset(0, 2) = s1.Cells(i, "C")
                s1.Cells(i, "D") = "Aktarıldı"
                s1.Range("A" & i & ":D" & i).Interior.Color = vbGreen
            End If
        End If
    End If
    If i = son Then
        Call xlsxyap
    End If
Next
End Sub

Sub xlsxyap()

Sayfa_Adı = Sheets("Sayfa2").Name

Klasor = ActiveWorkbook.Path & Application.PathSeparator

With Application
    .ScreenUpdating = False
    .EnableEvents = False
End With

Dim ds, a
Set ds = CreateObject("Scripting.FileSystemObject")
Dim sayfa As Worksheet
For Each sayfa In Worksheets
    If sayfa.Name = Sayfa_Adı Then
        For i = Len(ThisWorkbook.Name) To 1 Step -1
            If Mid(ThisWorkbook.Name, i, 1) = "." Then
                Dosya_adi = "Banka Talimatı"
                Exit For
            End If
        Next
        For Each Dosya In CreateObject("Scripting.FileSystemObject").GetFolder(Klasor).Files
            If Mid(Dosya.Name, 1, Len(Dosya_adi)) = Dosya_adi Then
                sat = sat + 1
                a = ds.FileExists(Klasor & Dosya_adi & " " & Format(Now, "yyyymmdd hhmmss")) ' & Uzanti)
                If a = True Then
                Else
                    son = 1
                    Exit For
                End If
            End If
        Next
        If son = 0 Then
            sat = sat + 1
        End If
        sayfa.Copy
        deger = Dosya_adi & " " & Format(Now, "yyyymmdd hhmmss") & Uzanti
        ActiveSheet.DrawingObjects.Delete
        For Each component In ActiveWorkbook.VBProject.VBComponents
            If component.Type <> 100 Then
                ActiveWorkbook.VBProject.VBComponents.Remove component
            Else
                Set modul = component.CodeModule
                modul.DeleteLines 1, modul.CountOfLines
            End If
        Next
        Dim wb As Workbook
        Set wb = ActiveWorkbook
        Application.DisplayAlerts = False
            With wb
                .SaveAs Klasor & deger
                .Close SaveChanges:=False
            End With
        Application.DisplayAlerts = True

        With Application
            .ScreenUpdating = True
            .EnableEvents = True
        End With
    End If
Next
End Sub