ميزان مراجعه

[رعد داود]

بسم الله الرحمن الرحيم

مرفق ملف موضح فيه المطلوب في ورقة ميزان المراجعه

لأظهار المجاميع التراكميه لكل حساب سواء مدين أم دائن ياريت بالكود

جربت عمل اخفاء الحسابات التي لاتوجد عليها حركه سببت بطء البرنامج لأن قد تصل السجلات الى 10,000 سجل او اكثر

برجاء المساعده من الأساتذه الأفاضل

يومية.rar

[جمال عبد السميع]

بصراحة أخي ( raad ) رقم account_id مختلف بين صفحة accounts وبين daily لذلك قربت بينهم ولكن النتيجة لم أختبرها فجرب المرفق وقولي هل هي النتيجة المرجوة أم لا

ميزان مراجعة.rar

[رعد داود]

مشكور أخ محمد على سرعة الرد والأجابه

بصراحه عملك رائع وجميل ,,, لكن المطلوب عندي عمل ميزان مراجعه يظهر فيه كافة مجاميع الحسابات سواء مدينه او دائنه

وبالاعتماد على account_id

الذي موجود في صفحة daily

أما صفحة account أنا عملتها للتجربه باستخدام كود أخفاء الصفوف التي قيمتها 0

وهذه الطريقه كما قلت بطيئه وخصوصا" قد تصل عندي السجلات الى 10,000 سجل او أكثر

وددت أيضا" عمل ذلك بالكود ان أمكن ............. أكرر صفحة account تجريبيه لاعلاقة لك بها

شكرا" مره أخرى استاذي العزيز

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

السلام عليكم

هذا الكود مجرب على قاعدة بيانات

فيها اكثر من 15000 سجل

Option Explicit


Private Const ContColmn As Integer = 5

'======================================================

'======================================================



Sub kh_mReport()

Dim xx

Dim x(), AryList()

Dim Rng As Range

Dim i As Long, LastRow As Long, iCont As Long

Dim c As Integer, m As Integer

Dim Md As Double, Dn As Double

Dim v1 As Double, v2 As Double

Dim S As String

'''''''''''''''''''''

Dim Co As New Collection

'============================================

With Cells.Worksheet

    LastRow = .Cells(Rows.Count, "A").End(xlUp).Row

    With .Range("A2")

        .Activate

        .Resize(1, ContColmn).ClearContents

        .Offset(1, 0).Resize(LastRow, ContColmn).Clear

    End With

End With

'============================================

With Sheets("dailyd1ary")

    LastRow = .Cells(Rows.Count, "C").End(xlUp).Row

    Set Rng = .Range("C2:G" & LastRow)

End With

'============================================

On Error GoTo kh_ex

kh_Application False

'''''''''''''''''''''

ReDim x(0 To 2)

With Rng

    For i = 1 To .Rows.Count

        v1 = 0: v2 = 0

1:      On Error Resume Next

        ''''''''''''''''''

        Md = Val(.Cells(i, 2))

        Dn = Val(.Cells(i, 3))

        S = CStr(.Cells(i, 4))

        ''''''''''''''''''

        x(0) = Val(S)

        x(1) = Md + v1

        x(2) = Dn + v2

        '''''''''''''''''''

        Co.Add x, S

        '''''''''''''''''''

        If Err Then

            v1 = Val(Co(S)(1)): v2 = Val(Co(S)(2))

            Co.Remove S

            Err.Clear

            GoTo 1

        End If

        '''''''''''''''''''

    Next

End With

'============================================

iCont = Co.Count

If iCont Then

    Set Rng = Sheets("accounts").Range("A2:A1000")

    ReDim AryList(1 To iCont, 1 To ContColmn)

    For i = 1 To iCont

        xx = Co.Item(i)

        On Error Resume Next

        m = WorksheetFunction.Match(xx(0), Rng, 0)

        If Err Then m = 0: Err.Clear

        AryList(i, 1) = xx(0)

        If m Then AryList(i, 2) = Rng.Cells(m, 2)

        AryList(i, 3) = xx(1)

        AryList(i, 4) = xx(2)

        AryList(i, 5) = Val(xx(1)) - Val(xx(2))

    Next

    '''''''''''''''''''''''''

    With Range("A2").Resize(iCont, ContColmn)

        If iCont > 1 Then .Rows(1).AutoFill .Cells, xlFillFormats

        .Value = AryList

        .Sort .Columns(1), xlAscending

    End With

    '''''''''''''''''''''''''

End If

'============================================

kh_ex:

kh_Application True

''''''''''''''''''

If Err Then

    MsgBox "Err.Number : " & Err.Number

    Err.Clear

Else

    MsgBox "تم تحديث الميزان بنجاح ", vbMsgBoxRight, "الحمدلله"

End If


Set Co = Nothing

Set Rng = Nothing

Erase AryList, x

End Sub


Sub kh_Application(mbol As Boolean)

With Application

    .Calculation = IIf(mbol, -4105, -4135)

    .ScreenUpdating = mbol

    .EnableEvents = mbol

End With

End Sub

المرفق 2003-2007

ميزان مراجعة.rar

[رعد داود]

عمل رائع من استاذ رائع

جزاك الله خير الجزاء ,,,,, علما" أنا لاحظت أعمالك استاذي بميزان المراجعه استخدمت اسلوب الفرز

بارك الله فيك وزادك الله من علمه

[جمال عبد السميع]

بعد إذن عالمنا الجليل ( عبد الله بقشير ) أنا لم أنظر إلي تحفة حضرتك حتي الأن وإلا لن يجرؤ تلميذ علي تقديم عمل بعد عمل حضرتك فهي محاولة مني للتجربة وسأصححها بعد النظر إلي ملرفق حرتك بارك الله فيك وفي أعمالك

جرب هذا المرفق وإن كان لايجوز التجربة بعد عمل عالمنا وأستاذنا عبدالله

ميزان مراجعة2.rar

[جمال عبد السميع]

ماشاء الله عالمنا الجليل الحمد لله إني قدمت مرفقي قبل النظر ألي تحفة حضرتك وإلا كنت كففت عن أي محاولة ولاحتي التفكير فيها

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

ماشاء الله عالمنا الجليل الحمد لله إني قدمت مرفقي قبل النظر ألي تحفة حضرتك وإلا كنت كففت عن أي محاولة ولاحتي التفكير فيها

اخي محمود ---حفظك الله

اكرمك الله على كلماتك الطيبة

اخي العزيز

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

وكلا يقدم حسب ما عنده

قد يكون في ملفك شي قد يحتاجه الاخرون

تقبل تحياتي وشكري

[رعد داود]

بسم الله الرحمن الرحيم

الاستاذ محمود معادلات رائعه وجميله ومفيده بارك الله فيك ,,, لكني لم أفهم سر الفلترة بالأرقام بالأعلى

الأستاذ عبد الله (( خبور)) الذي كله خير وعطاء ,,, جربت أعدل الكود ليكون بصوره جديده لميزان المراجعه ,,, من حيث جماليه

وحسب مامطلوب من الرقابه الماليه ,,,, وبصراحه لم أفلح بدقه به بعض المفردات لم أعرفها

أرفق لكم نفس الملف وأضفت به صفحة code , daily وميزان 2 لعمل المطلوب الجديد

ميزان مراجعة.rar

[رعد داود]

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

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

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

لم نفهم الطلب

اشرح طلبك بالتفصيل

[رعد داود]

الأستاذ الفاضل عبد الله الخير

السلام عليكم

قصدي ,,, أنه ماذا لو تم تعديل ميزان المراجعه كما مصمم بالورقه المسماة (( ميزان 2)) وتم تغيير أسم ورقة ACCOUNTS لتصبح على شكل الورقه المسماة Code وورقة daiy1diary لتكون على شكل الورقه المسماة daily وارفق هنا أيضا البرنامج الذي عدلتم عليه فيه الأوراق القديمه والأوراق الجديده المقترحه وبنفس كود التحديث الرائع الذي ذكرتموه ,,, مع أضافة مجاميع تراكميه للأيرادات والنفقات والموجودات الماليه

بصراحه أنا استخدم حاليا " طريقتكم بأحد البرامج من أخفاء الصفوف التي لاتحتوي على مبالغ لا بالمدين ولا بالدائن وعجبتني فكرة الكود للتحديث رائع جدا"

[رعد داود]

ارفق الملف مره اخرى

ميزان مراجعة.rar

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

daiy1diary

ورقة فيها بيانات

اما هذه daily

فاضية

اين بياناتك ؟؟؟

الاعمدة التي تريد تراكمها اين هي ؟؟

اشرح طلبك مفصلا

اخي الكريم

[رعد داود]

بسم الله الرحمن الرحيم

السيد الفاضل الأستاذ خبور المحترم ,,,, دعائي لكم بقبول الأعمال ونسأله تعالى أن يوفقكم لعمل الخير

أرفق الملف مره أخرى بعد درج بيانات في ورقة daily التي هي مصدر البيانات (( رقم الدليل + أسم الحساب + مدين + دائن + مركز التكلفه ))

والأعمده التي اريد تراكمها بعد استخلاص المجاميع التراكميه ,,,(( الأيرادات وتحت القسم 1)) والنفقات تحت القسم 2 والموجودات الماليه تحت القسم 31 والصندوق والسلف ووو من الأقسام المرقمه 35 36 37 38 39 40 41 42

43

بحسب الدليل المحاسبي الموجود في ورقة code تحت مسمى قسم

ميزان مراجعة.rar

[رعد داود]

الأستاذ الكبير عبد الله المحترم

هل لازال الأمر غير واضحا" عندكم ؟؟

للرفع ان تمكنتم من الحل وأنتم جديرين بأيجاد الحل

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

الأستاذ الكبير عبد الله المحترم

هل لازال الأمر غير واضحا" عندكم ؟؟

للرفع ان تمكنتم من الحل وأنتم جديرين بأيجاد الحل

كل تاخير وفيه خير

استخدمت كود آخر اسرع من السابق

الكود:

Option Explicit


Private Const ContColmn As Integer = 11

'======================================================

'======================================================


Sub kh_m2Report()

Dim obj As Object

Dim x(), AryList()

Dim iKey

Dim iTm As Range, Rng As Range

Dim LastRow As Long, iCont As Long

Dim i As Long, ii As Long, iii As Long

Dim c As Integer, m As Integer

Dim Md As Double, Dn As Double

'============================================

Set obj = CreateObject("Scripting.Dictionary")

'============================================

With Cells.Worksheet

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

    With .Range("B5")

        .Activate

        .Resize(1, ContColmn).ClearContents

        .Offset(1, 0).Resize(LastRow, ContColmn).Clear

    End With

End With

'============================================

With Sheets("daily")

    LastRow = .Cells(Rows.Count, "A").End(xlUp).Row

    Set Rng = .Range("A4:A" & LastRow)

End With

'============================================

On Error GoTo kh_ex

kh_Application False

'============================================

    For Each iTm In Rng

        iKey = Val(iTm.Cells(1, 5))

        Md = Val(iTm.Cells(1, 7))

        Dn = Val(iTm.Cells(1, 8))

        '''''''''''''''''''

        If obj.Exists(iKey) Then

            iii = obj(iKey)

            ''''''''''''''''''

            x(2, iii) = Val(x(2, iii)) + Md

            x(3, iii) = Val(x(3, iii)) + Dn

        Else

            ii = ii + 1

            ReDim Preserve x(1 To 3, 1 To ii)

            obj.Add iKey, ii

            ''''''''''''''''''

            x(1, ii) = iKey

            x(2, ii) = Md

            x(3, ii) = Dn

        End If

    Next

'============================================

iCont = obj.Count

If iCont Then

    Set Rng = Sheets("code").Range("A2:A350")

    ReDim AryList(1 To iCont, 1 To ContColmn)

    For i = 1 To iCont

        ''''''''''''''''''

        On Error Resume Next

        iKey = x(1, i)

        m = WorksheetFunction.Match(iKey, Rng, 0)

        If Err Then m = 0: Err.Clear

        ''''''''''''''''''

        Md = x(2, i): Dn = x(3, i)

        AryList(i, 1) = Md

        AryList(i, 2) = iKey

        ''''''''''''''''''

        If m Then

            For c = 3 To 9

                AryList(i, c) = Rng.Cells(m, c - 1)

            Next

        End If

        ''''''''''''''''''

        AryList(i, 10) = Dn

        AryList(i, 11) = Md - Dn

        ''''''''''''''''''

    Next

    '============================================

    With Range("B5").Resize(iCont, ContColmn)

        If iCont > 1 Then .Rows(1).AutoFill .Cells, xlFillFormats

        .Value = AryList

        .Sort .Columns(2), xlAscending

    End With

    '''''''''''''''''''''''''

End If

'============================================


kh_ex:

kh_Application True

''''''''''''''''''

If Err Then

    MsgBox "Err.Number : " & Err.Number

    Err.Clear

Else

    MsgBox "تم تحديث الميزان بنجاح ", vbMsgBoxRight, "الحمدلله"

End If


''''''''''''''''''

Set obj = Nothing

Set Rng = Nothing

Erase x, AryList

''''''''''''''''''

End Sub

المرفق 2003-2007

ميزان مراجعة للاخ ريد2.rar

[الـعيدروس]

السلام عليكم

استاذ عبدالله باقشير حفظك الله

عمل في قمة الروعه

جزاك الله كل خير لما تقدمه لنا من اعمال احترافيه

تقبل مروري

[رعد داود]

كل الشكر والأمتنان للأستاذ الكبير خبو الخير عبد الله الصالح

أمنياتي لكم بدوام الصحة والعافيه

[eslamneo2]

السلام عليكم 

اخواتي كل عام وانتم بخير رمضان كريم 

اكبر اثبات ان العلم يفيد ع مدار الزمن ردي دا

انا محاسب وقت الموضوع دا كنت لسه متخرجتش حاليا انا خبره 10 اعوام 

كلها حسابات عملاء وموردين ومخزن ولم تكن ف الحسابات العامه ولا عمل الميزانيه 

حتى خبرتي ف الاكسيل هي معادلات vlookup ,sumif, if , pivot table 

لم اقم بعمل شيت كامل لحسابات من قبل ويكون مربوط ببعضه ويسمع تلقائي ميزان او قوائم

حاليا جاتلي فرصه امسك حسابات مصنع حديث الميلاد واريد ان اخوض التجربه واتعلم خاصه انها يمكن ان لا تتكرر مره اخرى 

عند استلام حسابات المصنع من المحاسب السابق طلبت منه ان يسلم لي ميزان مراجعه ونقوم باعتماده من صاحب المصنع

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

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

امساه الله بالخير وجازاه نعم الجزاء عن مساعدته لينا

ولكن عندي اساله لو تسمحولي

هل الشيت قابل اني اخده اعدل عليه واشتغل بيه ؟

بعد اذن صاحب الموضوع

وهل  عند اضافه قيوم جديده ( صفوف جديده ) في الشيت الخاص بها وعند التحديث هل سيتم قرائتها تلقائي في ميزان المراجعه

لاني لا ارى معادلات 

ايضا عند الضغط على زرار " تجديث " تظهر رساله بصندوق صغير بحروف غير مقروئه وبها زرار ok تقريبا اقوم بالظغط عليه يختفي

اخيرا

اي شخص يرغب بنصيحتي ياريت لا تبخل 

انا عارف اني قصرت في حق نفسي علميا ولكن لعلنا ندرك ما فاتنا

وهل ممكن اضافه عمل القوائم ايضا عن طريق الاكسيل ؟

عذرا للاطاله