تعديل على الكود لاضافة حقل المدور في بداية كل صفحة جديده

[ابو مارفن]

السلام عليكم محتاج تعديل على الكود لاضافة حقل المدور في بداية كل صفحة جديده يحتوى على مجموع الصفحة السابقة لكي يتم جمعه مع الصفحة التالية وفي الورقة الاخيرة يكون المجموع الكلي لجميع الصفحات 
لكي يقوم الكود بتنفيذ كما هو موضح في صفحة البيانات مع جزيل الشكر والتقدير

معاهد.xlsm تحديد عدد صفوف للصفحة ومجموعها.xlsm

تم تعديل مارس 23 بواسطه ابو مارفن

[محمد هشام.]

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

للتنفيد على المصنف الخارجي معاهد  ورقة معهد 

Public Property Get f() As Worksheet: Set f = ThisWorkbook.Sheets("test"): End Property
Public Property Get CrWS() As Worksheet
    Dim wbName As String, wsName As String
    wbName = "معاهد.xlsm"
    wsName = "معهد"
    On Error Resume Next
    Set CrWS = Workbooks(wbName).Sheets(wsName)
    On Error GoTo 0
End Property
Sub Split_Rows()
    Dim xColor As Long: xColor = RGB(204, 255, 204)
    Dim LastRow As Long, i As Long, StartRow As Long, EndRow As Long, TotalSum As Double
    Dim k As Integer, Irow As Integer, r As Long, count As Long, tbl As Double, j As Double
    
    Const SumRng As String = "المجموع"
    Const ColArr As String = "المدور"
    Const SumPages As String = "المجموع الكلي للصفحات"
    
    If CrWS Is Nothing Then: MsgBox "لم يتم العثور على المصنف أو الورقة المحددة", vbExclamation: Exit Sub

    k = f.Range("G1").Value
    If k <= 0 Then MsgBox "G1:" & "يرجى تحديد عدد الصفوف المطلوبة في الخلية", vbInformation: Exit Sub

    With Application
        .ScreenUpdating = False: .Calculation = xlCalculationManual
        With CrWS
            .ResetAllPageBreaks

            LastRow = .Cells(.Rows.count, "B").End(xlUp).Row
            For i = LastRow To 2 Step -1
                If .Cells(i, "B").Value = SumRng Or _
                   .Cells(i, "B").Value = ColArr Or _
                   .Cells(i, "B").Value = SumPages Or .Cells(i, "B").Value = "" Then
                    .Range("A" & i & ":E" & i).Interior.ColorIndex = xlNone
                    .Range("A" & i & ":E" & i).Delete
                End If
            Next i

            LastRow = .Cells(.Rows.count, "A").End(xlUp).Row
            StartRow = 2
            tbl = 0
            TotalSum = 0

            i = StartRow
            Do While i <= LastRow
                EndRow = i + k - 1
                If EndRow > LastRow Then EndRow = LastRow
                j = Application.WorksheetFunction.Sum(.Range("E" & i & ":E" & EndRow))
                TotalSum = TotalSum + j

                If EndRow < LastRow Then
                    .Rows(EndRow + 1).Insert Shift:=xlDown
                    .Cells(EndRow + 1, "B").Value = SumRng
                    .Cells(EndRow + 1, "E").Value = j + tbl
                    .Range("A" & EndRow + 1 & ":E" & EndRow + 1).Interior.Color = xColor

                    .Rows(EndRow + 2).Insert Shift:=xlDown
                    .Cells(EndRow + 2, "B").Value = ColArr
                    .Cells(EndRow + 2, "E").Value = j + tbl
                    .Range("A" & EndRow + 2 & ":E" & EndRow + 2).Interior.Color = xColor

                    tbl = j + tbl
                    LastRow = LastRow + 2
                End If

                i = EndRow + 3
            Loop

            Irow = .Cells(.Rows.count, "A").End(xlUp).Row
            .Rows(Irow + 1).Insert Shift:=xlDown
            With .Cells(Irow + 1, "B")
                .Value = SumPages
                .Offset(0, 3).Value = TotalSum
                .Resize(1, 4).Font.Size = 18
                .Parent.Range("A" & Irow + 1 & ":E" & Irow + 1).Interior.Color = xColor
            End With

            .Range("A2:A" & .Cells(.Rows.count, "B").End(xlUp).Row).ClearContents
            For r = 2 To .Cells(.Rows.count, "B").End(xlUp).Row
                If .Cells(r, 2).Value <> SumRng And .Cells(r, 2).Value <> ColArr And _
                   .Cells(r, 2).Value <> SumPages Then
                    .Cells(r, 1).Value = count + 1
                    count = count + 1
                End If
            Next r
        End With

        If Not CrWS Is Nothing Then
             Call PrintArea_data(CrWS)
        End If

        .ScreenUpdating = True: .Calculation = xlCalculationAutomatic
    End With
End Sub

'============================================
Sub déleteRows()
    Const SumRng As String = "المجموع"
    Const ColArr As String = "المدور"
    Const SumPages As String = "المجموع الكلي للصفحات"
    Dim LastRow As Long, i As Long

    If CrWS Is Nothing Then: MsgBox "لم يتم العثور على المصنف أو الورقة المحددة", vbExclamation: Exit Sub

    Application.ScreenUpdating = False
    With CrWS
        .ResetAllPageBreaks

        LastRow = .Cells(.Rows.count, "B").End(xlUp).Row

        For i = LastRow To 2 Step -1
            If .Cells(i, "B").Value = SumRng Or _
               .Cells(i, "B").Value = ColArr Or _
               .Cells(i, "B").Value = SumPages Or .Cells(i, "B").Value = "" Then
                .Range("A" & i & ":E" & i).Interior.ColorIndex = xlNone
                .Range("A" & i & ":E" & i).Delete
            End If
        Next i
    End With
    Application.ScreenUpdating = True
End Sub

'====================================
Sub PrintArea_data(CrWS As Worksheet)
    Dim rCount As Long, tmps As Long, i As Long
    Dim lastCol As Long, OnRng As Range, n As Long
    
    n = f.Range("G1").Value + 2
    
    If n <= 0 Then Exit Sub
    tmps = 2
    CrWS.ResetAllPageBreaks
    rCount = CrWS.Cells(CrWS.Rows.count, 2).End(xlUp).Row

    If rCount > tmps + n Then
        For i = tmps + n To rCount Step n
            CrWS.HPageBreaks.Add Before:=CrWS.Rows(i)
        Next i
    End If

    lastCol = CrWS.Cells(1, "E").Column
    Set OnRng = CrWS.Range(CrWS.Cells(tmps, 1), CrWS.Cells(rCount, lastCol))
    CrWS.PageSetup.PrintArea = OnRng.Address
    CrWS.VPageBreaks.Add Before:=CrWS.Columns(lastCol + 1)
    
    With CrWS.PageSetup
        .Orientation = xlPortrait
        .PaperSize = xlPaperA4
        .FitToPagesWide = 1
        .FitToPagesTall = False
    End With
End Sub

 

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

 

Public Property Get CrWS() As Worksheet: Set CrWS = Sheets("test"): End Property
Sub Split_Rows()
    Const SumRng As String = "المجموع"
    Const ColArr As String = "المدور"
    Const SumPages As String = "المجموع الكلي للصفحات"
    Dim xColor As Long: xColor = RGB(204, 255, 204)
    Dim LastRow As Long, i As Long, StartRow As Long, EndRow As Long
    Dim k As Integer, j As Integer, r As Long, count As Long
    Dim tbl As Double, TotalSum As Double, Irow As Double

    k = CrWS.Range("G1").Value
    If CrWS.Name <> "test" Or k <= 0 Then MsgBox "G1:" & "يرجى تحديد عدد الصفوف المطلوبة في الخلية", vbInformation: Exit Sub

    With Application
        .ScreenUpdating = False: .Calculation = xlCalculationManual
        With CrWS
            .ResetAllPageBreaks

            LastRow = .Cells(.Rows.count, "B").End(xlUp).Row
            For i = LastRow To 2 Step -1
                If .Cells(i, "B").Value = SumRng Or _
                   .Cells(i, "B").Value = ColArr Or _
                   .Cells(i, "B").Value = SumPages Or .Cells(i, "B").Value = "" Then
                   .Range("A" & i & ":E" & i).Interior.ColorIndex = xlNone
                   .Range("A" & i & ":E" & i).Delete
                End If
            Next i

            LastRow = .Cells(.Rows.count, "A").End(xlUp).Row
            StartRow = 2
            tbl = 0
            TotalSum = 0

            i = StartRow
            Do While i <= LastRow
                EndRow = i + k - 1
                If EndRow > LastRow Then EndRow = LastRow

                Irow = Application.WorksheetFunction.Sum(.Range("E" & i & ":E" & EndRow))
                TotalSum = TotalSum + Irow

                If EndRow < LastRow Then
                    .Rows(EndRow + 1).Insert Shift:=xlDown
                    .Cells(EndRow + 1, "B").Value = SumRng
                    .Cells(EndRow + 1, "E").Value = Irow + tbl
                    .Range("A" & EndRow + 1 & ":E" & EndRow + 1).Interior.Color = xColor

                    .Rows(EndRow + 2).Insert Shift:=xlDown
                    .Cells(EndRow + 2, "B").Value = ColArr
                    .Cells(EndRow + 2, "E").Value = Irow + tbl
                    .Range("A" & EndRow + 2 & ":E" & EndRow + 2).Interior.Color = xColor

                    tbl = Irow + tbl
                    LastRow = LastRow + 2
                End If

                i = EndRow + 3
            Loop

            j = .Cells(.Rows.count, "A").End(xlUp).Row
            .Rows(j + 1).Insert Shift:=xlDown
            With .Cells(j + 1, "B")
                .Value = SumPages
                .Offset(0, 3).Value = TotalSum
                .Resize(1, 4).Font.Size = 18
                .Parent.Range("A" & j + 1 & ":E" & j + 1).Interior.Color = xColor
            End With

            .Range("A2:A" & .Cells(.Rows.count, "B").End(xlUp).Row).ClearContents
            For r = 2 To .Cells(.Rows.count, "B").End(xlUp).Row
                If .Cells(r, 2).Value <> SumRng And .Cells(r, 2).Value <> ColArr And _
                   .Cells(r, 2).Value <> SumPages Then
                    .Cells(r, 1).Value = count + 1
                    count = count + 1
                End If
            Next r
          End With
        Call PrintArea_data
        .ScreenUpdating = True: .Calculation = xlCalculationAutomatic
    End With
End Sub

 

للتنفيد على مصنف خارجي.rar تحديد عدد صفوف للصفحة ومجموعها v2.xlsm

تم تعديل الإثنين at 01:40 بواسطه محمد هشام.

[ابو مارفن]

مشكور استاذي العزيز الله يحفظك ويبارك بجهودك ابدعت بس فاصل الصفحات ان يكون بين المجموع والمدور اي ان يكون المجموع في اخر صف الصفحة والمدور ان يكون بداية الصفحة التالية ومشكور على جهودك

[محمد هشام.]

18 ساعات مضت, ابو مارفن said:

ان يكون بين المجموع والمدور اي ان يكون المجموع في اخر صف الصفحة والمدور ان يكون بداية الصفحة التالية

لقد تم الإعتماد مسبقا على الكود الأول والدي كان يتضمن وضع الفواصل بعد كلمة Sum

تفضل أخي تم تعديل الكود ليتناسب مع طلبك 

لحفظ الصفحات في مجلد في نفس مسار المصنف بصيغة PDF جرب هدا 

Option Explicit
Sub Save_PDF()
    On Error GoTo SupApp

    Dim WS As Worksheet, sPath As String, sFolder As String
    Dim count As Long, lastRow As Long, cell As Range, début As Integer
    Set WS = Sheets("test")
    
    lastRow = WS.Cells(WS.Rows.count, "B").End(xlUp).Row
    début = 1: count = 0
    
    For Each cell In WS.Range("B2:B" & lastRow)
        If InStr(cell.Value, "المجموع") > 0 Then count = count + 1
    Next cell
    
    If count > 0 Then
        If MsgBox("هل ترغب بحفظ الصفحات من " & début & " إلى " & count & "؟", _
                  vbYesNo + vbExclamation, "تأكيد") = vbNo Then Exit Sub
        
        sFolder = ThisWorkbook.Path & "\ملفات PDF"
        If Dir(sFolder, vbDirectory) = "" Then MkDir sFolder
        sPath = sFolder & "\" & "Page_" & début & "-" & count & ".pdf"

        WS.ExportAsFixedFormat Type:=xlTypePDF, FileName:=sPath, Quality:=xlQualityStandard, _
                               IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
        
        MsgBox "تم حفظ الملف بنجاح", vbInformation
    End If
    
SupApp:
    Set WS = Nothing
End Sub

 

 

 

تحديد عدد صفوف للصفحة ومجموعها -v3.xlsm للتنفيد على مصنف خارجي.rar Test PDF.pdf

تم تعديل الأربعاء at 03:38 بواسطه محمد هشام.

[ابو مارفن]

عاشت ايدك ومشكور استاذي العزيز على جهودك الله يحفظك ويرحم امواتك ويجعلها بميزان حسناتك تحياتي لحضرتك