كود حساب شيت وترحيل النتائج

[ايهاب الغريب]

السلام عليكم ورحمه الله وبركاته
من فضلك أساتذتي الأفاضل

عايز كود في زرار حساب وترحيل يعمل عمليه حساب للشيت وذلك بتغيير قيمه الخليه C 14 من اول 2012 حتى السنه الحاليه 

وبناء على وجود القيمه في العمود U من عدمه يعمل عمليه ترحيل الى شيت حساب لكل من له قيمه في العمود U
وذلك كما في المثال عن سنتي ٢٠١٢ و٢٠١٣   ..ولكم جزيل الشكر 
مذكره تقدير1111 ارباح.xlsm

[lionheart]

Have a look. Is that the desired output

[lionheart]

Sub Test()
    Const sSheetName As String = "Report"
    Dim e, ws As Worksheet, f As Boolean, t1 As Double, t2 As Double, x As Long, y As Long, r As Long, iRow As Long, fRow As Long
    Application.ScreenUpdating = False
        Set ws = ThisWorkbook.Worksheets("MIN")
        On Error Resume Next
            Application.DisplayAlerts = False
                ThisWorkbook.Worksheets(sSheetName).Delete
            Application.DisplayAlerts = True
        On Error GoTo 0
        Sheets.Add(After:=Sheets(Sheets.Count)).Name = sSheetName
        With ThisWorkbook.Worksheets(sSheetName)
            .DisplayRightToLeft = True
            .Cells.Clear
            With .Cells
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
            End With
            iRow = 1
            For y = 2012 To Year(Date)
                fRow = iRow
                t1 = 0: t2 = 0: x = 0
                ws.Range("C14").Value = y
                With .Cells(iRow, 1)
                    .Value = y
                    .Font.Bold = True
                    .Interior.Color = RGB(219, 219, 219)
                End With
                For Each e In Array("16|30", "32|41", "43|52")
                    x = x + 1
                    f = False
                    For r = Val(Split(e, "|")(0)) To Val(Split(e, "|")(1))
                        If ws.Cells(r, "U").Value > 0 And ws.Cells(r, "U").Value <> Empty Then
                            If f = False Then
                                iRow = iRow + 1
                                If x = 2 Then iRow = iRow + 1
                                .Cells(iRow, 2).Value = ws.Range(IIf(x = 1, "D", "B") & Val(Split(e, "|")(0)) - 1).Value
                                .Cells(iRow, 3).Resize(, 6).Value = ws.Range("P" & Val(Split(e, "|")(0)) - 1).Resize(, 6).Value
                                .Cells(iRow, 2).Resize(, 7).Interior.Color = vbYellow
                                f = True
                            End If
                            iRow = iRow + 1
                            .Cells(iRow, 2).Value = ws.Cells(r, IIf(x = 1, "D", "B")).Value
                            .Cells(iRow, 3).Resize(, 6).Value = ws.Cells(r, "P").Resize(, 6).Value
                            t1 = t1 + .Cells(iRow, "F").Value
                            t2 = t2 + .Cells(iRow, "H").Value
                        End If
                    Next r
                    iRow = iRow + 1
                    If x = 1 Then iRow = iRow - 1
                Next e
                iRow = iRow + 1
                .Cells(iRow, 2).Value = "Total"
                With .Cells(iRow, "F")
                    .Value = t1
                    .Interior.Color = vbCyan
                End With
                With .Cells(iRow, "H")
                    .Value = t2
                    .Interior.Color = vbCyan
                End With
                iRow = iRow + 2
                With .Range(.Cells(fRow, 2), .Cells(iRow - 2, 8))
                    .Borders.Value = 1
                    .BorderAround Weight:=3
                End With
                f = False
            Next y
            .Rows.RowHeight = 19
            .Columns(1).ColumnWidth = 9
            .Columns("B:H").AutoFit
        End With
    Application.ScreenUpdating = True
End Sub

 

[ايهاب الغريب]

تمام تسلم ايدك ممتاز

لكن يوجد بعض الملاحظات في التقرير كالتالي

[lionheart]

The image is not clear for me

You can upload a file and highlight the notes

[ايهاب الغريب]

السلام عليكم ورحمه الله وبركاته ..أولا لك كل الشكر والتقدير على هذا المجهود الرائع ..ثانياً اطلب منك سعة صدرك وان كنت أثقل عليكم

 كنت عايز تقريب الارقام في شيت report في  العمود C والعمود E والعمود F والعمود H   الى اقرب عددين وان تكون القيمه في العمود G نسبه مئويه وليست عشريه

 كما تم استيراد رقم السياره وتحتها ارقام السيارات يتم استيراد البند ومن تحتها البنود في النشاط التجاري ويتم استيراد العنوان وتحته العناوين في نشاط ثروه عقاريه

يوجد خطأ في حساب الشهور الفعلية فلاحظت أنه في بعض السنوات يزيد عن ١٢ وهذا فعلياً مستحيل حيث لا يوجد سنة أكثر من ١٢ شهر فأرجو تصحيح هذا الخطأ والتقريب إلي أقرب عددين أيضا ...أخير كل الشكر والتقدير 

مذكره تقدير1111 ارباح.xlsm

[lionheart]

The last point is not clear for me

Sub Test()
    Const sSheetName As String = "Report"
    Dim e, ws As Worksheet, f As Boolean, t1 As Double, t2 As Double, x As Long, y As Long, r As Long, iRow As Long, fRow As Long
    Application.ScreenUpdating = False
        Set ws = ThisWorkbook.Worksheets("MIN")
        On Error Resume Next
            Application.DisplayAlerts = False
                ThisWorkbook.Worksheets(sSheetName).Delete
            Application.DisplayAlerts = True
        On Error GoTo 0
        Sheets.Add(After:=Sheets(Sheets.Count)).Name = sSheetName
        With ThisWorkbook.Worksheets(sSheetName)
            .DisplayRightToLeft = True
            .Cells.Clear
            With .Cells
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
            End With
            iRow = 1
            For y = 2012 To Year(Date)
                fRow = iRow
                t1 = 0: t2 = 0: x = 0
                ws.Range("C14").Value = y
                With .Cells(iRow, 1)
                    .Value = y
                    .Font.Bold = True
                    .Interior.Color = RGB(219, 219, 219)
                End With
                For Each e In Array("16|30", "32|41", "43|52")
                    x = x + 1
                    f = False
                    For r = Val(Split(e, "|")(0)) To Val(Split(e, "|")(1))
                        If ws.Cells(r, "U").Value > 0 And ws.Cells(r, "U").Value <> Empty Then
                            If f = False Then
                                iRow = iRow + 1
                                If x = 2 Then iRow = iRow + 1
                                .Cells(iRow, 2).Value = ws.Range(IIf(x = 1, "D", "B") & Val(Split(e, "|")(0)) - 1).Value
                                .Cells(iRow, 3).Resize(, 6).Value = ws.Range("P" & Val(Split(e, "|")(0)) - 1).Resize(, 6).Value
                                .Cells(iRow, 2).Resize(, 7).Interior.Color = vbYellow
                                f = True
                            End If
                            iRow = iRow + 1
                            .Cells(iRow, 2).Value = ws.Cells(r, IIf(x = 1, "D", "B")).Value
                            .Cells(iRow, 3).Resize(, 6).Value = ws.Cells(r, "P").Resize(, 6).Value
                            t1 = t1 + .Cells(iRow, "F").Value
                            t2 = t2 + .Cells(iRow, "H").Value
                        End If
                    Next r
                    iRow = iRow + 1
                    If x = 1 Then iRow = iRow - 1
                Next e
                iRow = iRow + 1
                .Cells(iRow, 2).Value = "Total"
                With .Cells(iRow, "F")
                    .Value = t1
                    .Interior.Color = vbCyan
                End With
                With .Cells(iRow, "H")
                    .Value = t2
                    .Interior.Color = vbCyan
                End With
                iRow = iRow + 2
                With .Range(.Cells(fRow, 2), .Cells(iRow - 2, 8))
                    .Borders.Value = 1
                    .BorderAround Weight:=3
                End With
                f = False
            Next y
            .Rows.RowHeight = 19
            .Columns(1).ColumnWidth = 9
            For Each e In Array(3, 5, 6, 8)
                .Columns(e).NumberFormat = "0.00"
            Next e
            .Columns(7).NumberFormat = "0%"
            .Columns("B:H").AutoFit
        End With
    Application.ScreenUpdating = True
End Sub

 

[ايهاب الغريب]

السلام عليكم ورحمه الله ...أولا جزاكم الله خيرا وتقبل أسفي ان كنت أثقلت عليكم ..ثانياً جاري تجربة الكود وإن شاء الله ثقتي بكم كبيرة

ثالثا : بالنسبة للنقطة التي أشرت أنها غير واضحة فأرجو أن يتسع صدرك لتوضيحها لأنها مهمة جداً في حساب الناتج 

المعادله الموجودة في العمود R لحساب عدد شهور العمل في السنة وذلك بدلالة قيم العمودية K و L  ويوجد خطأ ما بالمعادلة حيث تكون القيمة أحيانا ١٢ وكسر وهذا واقعياً يعتبر مستحيل حيث أن عدد شهور السنة لا يزيد بأي حال من الأحوال عن ١٢ شهر صحيح

وبناء عليه ..أرجو من حضرتك مراجعة المعادله في العمود R وتصحيح الخطأ

بعد تجربة الكود وجدت أنه يعطي ورقة جديدة باسم report  خاليه ولا يوجد بها أي بيانات ..هذا للعلم وعمل اللازم ..وجزاكم الله خيرا