ميزان مراجعه

**رعد داود** · ديسمبر 19, 2012

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

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

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

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

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

**جمال عبد السميع** · ديسمبر 19, 2012

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

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

**رعد داود** · ديسمبر 19, 2012

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

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

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

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

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

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

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

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

**عبدالله باقشير** · ديسمبر 19, 2012

السلام عليكم

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

فيها اكثر من 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

**رعد داود** · ديسمبر 19, 2012

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

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

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

**جمال عبد السميع** · ديسمبر 19, 2012

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

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

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

**جمال عبد السميع** · ديسمبر 19, 2012

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

**عبدالله باقشير** · ديسمبر 19, 2012

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

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

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

اخي العزيز

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

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

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

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

**رعد داود** · ديسمبر 20, 2012

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

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

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

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

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

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

**رعد داود** · ديسمبر 21, 2012

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

**عبدالله باقشير** · ديسمبر 21, 2012

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

لم نفهم الطلب

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

**رعد داود** · ديسمبر 21, 2012

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

السلام عليكم

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

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

**رعد داود** · ديسمبر 21, 2012

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

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

**عبدالله باقشير** · ديسمبر 21, 2012

daiy1diary

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

اما هذه daily

فاضية

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

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

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

اخي الكريم

**رعد داود** · ديسمبر 22, 2012

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

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

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

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

43

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

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

**رعد داود** · ديسمبر 23, 2012

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

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

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

**عبدالله باقشير** · ديسمبر 24, 2012

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

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

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

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

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

الكود:


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

**الـعيدروس** · ديسمبر 25, 2012

السلام عليكم

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

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

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

تقبل مروري

**رعد داود** · ديسمبر 25, 2012

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

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

eslamneo2 · April 2

السلام عليكم

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

اخيرا

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

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

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

عذرا للاطاله

تسجيل الدخول

ميزان مراجعه

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

رعد داود

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

رعد داود

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

رعد داود

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

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

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

رعد داود

رعد داود

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

رعد داود

رعد داود

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

رعد داود

رعد داود

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

الـعيدروس

رعد داود

eslamneo2

Join the conversation

تصفح هذا الموضوع مؤخراً 0 اعضاء متواجدين الان

تصفح الموقع

تصفح جديد الموقع

Support

Important Information