تقسيمة حافظة مرتبات 250,000

[منير ربيع]

السلام عليكم و رحمة الله وبركاته هذه حافظة مرتبات الكترونية أريد تقسيمها على ثلاثة أجزاء كالتالي

الأول يساوي 250,000 بدون زيادة او نقصان

الثاني  يساوي 250,000 بدون زيادة او نقصان

الثالث باقي القيمة

لايهم الاحتفاظ بترتيب الصفوف

و شكراحافظة إلكترونية مصارف التجاري052025.xls

[hegazee]

 وعليكم السلام و رحمة الله و بركاته

أخي الكريم الطلب غير واضح لأن الطلب الأول و الثاني نفس القيمة بالضبط يساوي 250000 مع العلم أنه لاتوجد أي خلية بها هذا الرقم

تم تعديل الثلاثاء at 10:39 بواسطه hegazee

[منير ربيع]

أريد تقسيم الجدول على 3 جداول منفصلة 

الجدول الاول قيمته تساوي 250 ألف و كذلك الثاني و الثالث يساوي المتبقي من القيمة

 

[hegazee]

تفضل أخي الكريم مع العلم أنه (كما أبلغتك سابق) لا توجد خلية واحدة بها رقم 250000. لذلك عند تجريب الملف تأكد من وضع الرقم المطلوب في أي خلية.

حافظة إلكترونية مصارف التجاري052025.xlsm

[محمد هشام.]

 وعليكم السلام ورحمة الله وبركاته

جرب هدا

 

 

Option Explicit
Const Salaries As Double = 250000

Sub SplitTables()
    Dim WS As Worksheet, Sh1 As Worksheet, Sh2 As Worksheet, Sh3 As Worksheet
    Dim lastRow As Long, i As Long, Tbl1 As Long, Tbl2 As Long, tbl3 As Long, arr
    Dim sum1 As Double, sum2 As Double, sum3 As Double, OnRng As Range, CrWS As Variant
    Dim tmp() As Double, n() As Long, ky() As Boolean, j() As Boolean, k() As Boolean

    SetApp False
    Set WS = ThisWorkbook.sheets("Net")

    TmpWS "تقسيم1": TmpWS "تقسيم2": TmpWS "تقسيم3"
    Set Sh1 = ThisWorkbook.sheets("تقسيم1")
    Set Sh2 = ThisWorkbook.sheets("تقسيم2")
    Set Sh3 = ThisWorkbook.sheets("تقسيم3")
    CrWS = Array(Sh1, Sh2, Sh3)

    For Each arr In CrWS
        arr.Columns("A:H").Clear
        arr.DisplayRightToLeft = True
    Next

    lastRow = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row
    ReDim tmp(2 To lastRow), n(2 To lastRow), ky(2 To lastRow)
    ReDim j(2 To lastRow), k(2 To lastRow)

    For i = 2 To lastRow
        tmp(i) = WS.Cells(i, "D").Value
        n(i) = i
    Next i

    Set OnRng = WS.[A1:H1]
    OnRng.Copy Sh1.[A1]: OnRng.Copy Sh2.[A1]: OnRng.Copy Sh3.[A1]
    Tbl1 = 2: Tbl2 = 2: tbl3 = 2: sum1 = 0: sum2 = 0: sum3 = 0
    For i = 2 To lastRow
        If tmp(i) > Salaries Then
            WS.Rows(n(i)).Copy Sh3.Rows(tbl3)
            tbl3 = tbl3 + 1
            ky(i) = True
            sum3 = sum3 + tmp(i)
        End If
    Next i

    If Not WsTotal(tmp, ky, Salaries, j) Then Call WsTotal(tmp, ky, Salaries, j)
    For i = 2 To lastRow: If j(i) Then ky(i) = True
    Next i
    If Not WsTotal(tmp, ky, Salaries, k) Then Call WsTotal(tmp, ky, Salaries, k)

    For i = 2 To lastRow
        If j(i) Then
            WS.Range("A" & n(i) & ":H" & n(i)).Copy Sh1.Range("A" & Tbl1)
            sum1 = sum1 + tmp(i)
            Tbl1 = Tbl1 + 1
        ElseIf k(i) Then
            WS.Range("A" & n(i) & ":H" & n(i)).Copy Sh2.Range("A" & Tbl2)
            sum2 = sum2 + tmp(i)
            Tbl2 = Tbl2 + 1
        ElseIf Not ky(i) Then
            WS.Range("A" & n(i) & ":H" & n(i)).Copy Sh3.Range("A" & tbl3)
            sum3 = sum3 + tmp(i)
            tbl3 = tbl3 + 1
        End If
    Next i
    AddTotal Sh1, Tbl1, sum1: AddTotal Sh2, Tbl2, sum2: AddTotal Sh3, tbl3, sum3
    ColArr CrWS
    WS.Activate
    MsgBox "تم تقسيم جدول الرواتب بنجاح", vbInformation
    SetApp True
End Sub

Private Sub AddTotal(sht As Worksheet, ling As Long, total As Double)
    sht.Cells(ling, "C").Value = "الإجمالي"
    sht.Cells(ling, "D").Value = Format(total, "0.00")
    With sht.Range(sht.Cells(ling, "C"), sht.Cells(ling, "D"))
        .Font.Bold = True: .Interior.Color = RGB(220, 230, 241)
    End With
End Sub

Private Sub ColArr(sheets As Variant)
    Dim sht As Variant
    For Each sht In sheets
        sht.Columns("A:H").AutoFit
    Next sht
End Sub
Private Sub TmpWS(sheetName As String)
    Dim WS As Worksheet
    On Error Resume Next
    Set WS = ThisWorkbook.sheets(sheetName)
    On Error GoTo 0
    If WS Is Nothing Then
        Set WS = ThisWorkbook.sheets.Add(After:=ThisWorkbook.sheets(ThisWorkbook.sheets.Count))
        WS.Name = sheetName
    End If
End Sub

 

 

 

حافظة إلكترونية مصارف التجاري052025 V-2.xls

تم تعديل منذ 17 دقائق بواسطه محمد هشام.