ترحيل البيانات من الشيت الرئيسي الي الشيت الفرعي حسب الشريحه

[fantap]

السلام عليكم

مرفق   ملف اكسيل يحتوي  علي 2 شيت  اكسيل  الشيت الرئيسي هو شيت العملاء  مكون من عدد 7 اعمدة   العمود الاول  هو اسم  العميل  العمود الثاني  هو  رقم حساب العميل  العمود الثالث هو الايداع  النقدي  العمود  الرابع هو السحب  النقدي  العمود  الخامس هو تحويلات الخارجيه  العمود  السادس هو للتحويلات  الداخليه  العمود  السابع  هو  للفتح  الجديد  و الشيت  الثاني  يسمي  شيت  الشرايح   اريد عندما  اعمل  عند عمل نسخ و لصق اسماء العملاء  و بيانتهم  يتم رحيل  البيانات  حسب شرائيهم في الجدول الثاني بشكل التوماتيكي  بحيث لو ان العميل يقوم  باي عمليه مثلا مثلا  يتم ترحيل  العميل  حسب الشريحه الخاصه به و نوع  العمليه سواء كانت ايداع او سحب او تحويل داخلي او خارجي او فتح جديد و عمل اجمالي حسب  المبالغ الخاصه به   

شرائح.xlsx

[عبدالله بشير عبدالله]

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

اضطررت الى تعديل الجدول قليلا في صفحة جدوال الشرائح 

الكود

Sub CalculateRanges()
    Dim wsClients As Worksheet
    Dim wsRanges As Worksheet
    Dim lastRowClients As Long
    Dim i As Long, j As Long, k As Long
    Dim count As Long
    Dim total As Double
    Dim depositValue As Double
    Dim rangeStart As Double
    Dim rangeEnd As Double
    Dim ranges As Variant
    Dim colIndex As Variant
    Dim infiniteRows As Variant
    
    Set wsClients = ThisWorkbook.Sheets("العملاء")
    Set wsRanges = ThisWorkbook.Sheets("جدوال الشرائح")
    
    lastRowClients = wsClients.Cells(wsClients.Rows.count, 1).End(xlUp).Row
    
    ranges = Array(Array(3, 7, 3), Array(10, 14, 4), Array(17, 21, 5), Array(24, 28, 6), Array(31, 35, 7))
    
    infiniteRows = Array(7, 14, 21, 28, 35)
    
    For k = LBound(ranges) To UBound(ranges)
        wsRanges.Range("D" & ranges(k)(0) & ":F" & ranges(k)(1)).ClearContents
        
        For i = ranges(k)(0) To ranges(k)(1)
            rangeStart = wsRanges.Cells(i, "B").Value
            
            If IsInArray(i, infiniteRows) Then
                rangeEnd = Application.WorksheetFunction.Large(wsClients.Range("C2:C" & lastRowClients), 1) * 10 ' اعتبار القيمة ما لا نهاية
            Else
                rangeEnd = wsRanges.Cells(i, "C").Value
            End If
            
            count = 0
            total = 0
            
            For j = 2 To lastRowClients
                depositValue = wsClients.Cells(j, ranges(k)(2)).Value
                
                If depositValue >= rangeStart And depositValue <= rangeEnd Then
                    count = count + 1
                    total = total + depositValue
                End If
            Next j
            
            wsRanges.Cells(i, "D").Value = count
            wsRanges.Cells(i, "E").Value = total
        Next i
        
        wsRanges.Cells(ranges(k)(1) + 1, "D").Formula = "=SUM(D" & ranges(k)(0) & ":D" & ranges(k)(1) & ")"
        wsRanges.Cells(ranges(k)(1) + 1, "E").Formula = "=SUM(E" & ranges(k)(0) & ":E" & ranges(k)(1) & ")"
    Next k
    

End Sub

Function IsInArray(valueToFind As Variant, arr As Variant) As Boolean
    Dim i As Long
    For i = LBound(arr) To UBound(arr)
        If arr(i) = valueToFind Then
            IsInArray = True
            Exit Function
        End If
    Next i
    IsInArray = False
End Function

الملف 

شرائح.xlsb

[fantap]

شكرا جزيلا  بارك الله في حضرتك.... خالص الاحنترام و التقدير

[عبدالله بشير عبدالله]

اتمنى لك كل التوفيق

 

 

تم تعديل ديسمبر 31, 2024 بواسطه عبدالله بشير عبدالله