اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

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


الردود الموصى بها

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

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

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

رابط هذا التعليق
شارك

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

 

  • Thanks 1
رابط هذا التعليق
شارك

  • 3 weeks later...

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

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

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

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

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

رابط هذا التعليق
شارك

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

 

  • Thanks 1
رابط هذا التعليق
شارك

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

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

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

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

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

 

 

رابط هذا التعليق
شارك

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

  • المتواجدين الان   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information