كيف يتم الترحيل بالكود لهذه القيود بشرط

[الفرس]

اخوانى الكرام

 

الكود لايكمل ترحيل القيود المتوازنة فى جانبى القيد وعدد حسابات الجانبين غير متساوية

 

بمعنى يمكن ان يكون قيد بالشكل التالى :

الجانب المدين :

                 النقدية =10000

                البنوك = 5000

الجانب الدائن :

                الايرادات=5000

                عهد   =7000

              المبيعات=3000

[ابو اياد ( الاسيوطى )]

السلام عليكم

اخى الفرس

اعتقد بعد البحث وجدتك ما تقصده

الاخوه عند الترحيل بطريقه الاخ // الفرس

يكون عدد المبالغ المدينه 2 هما النقديه والبنك ويتم ترحيلهم بدقه الى قاعده البيانات

اما الجزء الخاطئ هو عدد الحسابات الدائنه 3 ولم يتم إلا ترحيل حسابين فقط هما الايرادات والعهد فقط

لم يتم ترحيل حساب المبيعات ولا مبلغه الـ 3000 الى قاعده البيانات

مشكور على الملاحظه الجيده وان شاء الله نجد حل وتعديل الكود من احد الاعضاء ولكنى سأحاول قدر المستطاع

ايضا ( مشكله بسيطه تم حلها ) ان لم يتم توجيه كل المبالغ على الحسابات كان الملف يقوم بالترحيل قمت بأضافه شرط اخر داخل الكود وهو اذا كانت g6 اكبر من او تساوى 1 لن يتم الترحيل هى التى تعنى عدم توجيه المبلغ على حساب بعينه

ايها الاخوه ننتظر منكم تعديل الكود لسد الثغره التى اكتشفها اخى الفرس

 

ارجو التنفيذ على المرفق

سعد عابد2.rar

[ابو اياد ( الاسيوطى )]

up

[أبو حنــــين]

السلام عليكم

بالنسبة لخطأ الترحيل

غير هذا السطر

For r = 7 To Sheets("Entry").[c40].End(xlUp).Row

بهذا السطر

For r = 7 To Sheets("Entry").UsedRange.Rows.Count

[الفرس]

الاخ الفاضل / أبو حنين

 

السلام عليكم

 

قمت بالتغيير الذى تفضلتم به وبالتجربه اتضح الكود يقوم بالترحيل ولكن قام بتكرار التاريخ ورقم السند والشرح الى السطر 44

 

رجاء معالجة التكرار وان امكن عمل تنسيق فصل بين كل سند والاخر بخط  وجزاكم الله خيرا

[الفرس]

للرفع

[ابو اياد ( الاسيوطى )]

up

[أبو حنــــين]

السلام عليكم

جرب هذا التعديل

Sub saad()

Application.ScreenUpdating = False
Sheets("Entry").Select
al = Sheets("Database").[e10000].End(xlUp).Row
If [d1] = "" Or [d2] = "" Or [d3] = "" Then
MsgBox "أكمل البيانات أولا"
Exit Sub
ElseIf Not [c4].Value = [d4].Value Then
MsgBox "تأكد من ادخال القيد مع توازن الطرفين", vbExclamation, "ادخال خاطئ"
Exit Sub
ElseIf Sheets("Database").Range("e" & al).Value = [d2].Value Then
MsgBox "تأكد من عدم تكرار القيد", vbExclamation, "ادخال خاطئ"
Exit Sub
End If
If MsgBox("هل تريد ترحيل البيانات الحالية", vbInformation + vbOKCancel, "ترحيل") = vbCancel Then Exit Sub
With Sheets("Entry")
R_C = .Cells(Rows.Count, "C").End(xlUp).Row: R_D = .Cells(Rows.Count, "D").End(xlUp).Row
R_E = .Cells(Rows.Count, "E").End(xlUp).Row: R_F = .Cells(Rows.Count, "F").End(xlUp).Row
R_Row = Application.WorksheetFunction.Max(R_C, R_D, R_E, R_F)
End With
For R = 7 To R_Row
With Sheets("Database")
Last = .Cells(Rows.Count, "D").End(xlUp).Row + 1
Sheets("Entry").Range("C" & R).Resize(1, 4).Copy
.Range("G" & Last).PasteSpecial xlPasteValues: .Range("D" & Last) = Sheets("Entry").Range("D1").Value
.Range("E" & Last) = Sheets("Entry").Range("D2").Value: .Range("F" & Last) = Sheets("Entry").Range("D3").Value
Last = Last + 1
End With
Next
With Sheets("Database")
Last1 = .Cells(Rows.Count, "D").End(xlUp).Row
.Range("D" & Last1 & ":J" & Last1).Borders.Value = 1
.Range("D" & Last1 & ":J" & Last1).Borders(xlEdgeTop).LineStyle = xlNone
.Range("D" & Last1 & ":J" & Last1).Borders(xlEdgeBottom).Weight = xlThick
.Range("D" & Last1 & ":J" & Last1).Borders(xlEdgeBottom).ColorIndex = 3
End With
With Sheets("Entry")
MsgBox "تم ترحيل بيانات السند رقم   " & .Range("D2") & "   بنجاح", vbInformation, "ترحيل"
.Range("C7:F40") = ""
.Range("D1:D3") = ""
End With
Application.ScreenUpdating = True
Application.CutCopyMode = False


End Sub

[saad abed]

اخى ابوحنين

اتتبع خطواتك

اسال الله ان يديم عليك نعمه

وان يجعل اولادك قرة عين لك

اللهم امين

[أبو حنــــين]

آمين آمين أخي سعد اسعد الله اوقاتك

ارجو ان يكون الكود قد ادى المطلوب وان كان هناك اضافة او استفسار فأنا جاهز ان شاء الله

جزاك الله خيرا

[ابو اياد ( الاسيوطى )]

السلام عليكم

استاذى الكبير // ابو حنين

بارك الله فيك على كل هذا التعب ولكن هناك خطأ ارجو ان تقوم حضرتك التطبيق على الملف بالمشاركه 27#

وتجرب وترى ما هو الخطأ لم يتم الترحيل فى الاماكن المناسبه 

ننتظرك ونرجوا من سيادتكم ارفاق الملف بعد التعديل تجنبا لأيه اخطأ اخرى يمكن ان تكون من جانبى

 

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

 

جزاك الله كل خير

[أبو حنــــين]

السلام عليكم

اخي محمود الخطأ كان في الخلية المدمجة في السطر

Last = .Cells(Rows.Count, "D").End(xlUp).Row + 1

و لتصحيح الخطأ غير فقط السطر السابق بالسطر التالي

Last = .Cells(Rows.Count, "G").End(xlUp).Row + 1

اي وضعنا الحرف  G  بدل الحرف  D

[ابو اياد ( الاسيوطى )]

السلام عليكم

استاذى الكبير // ابوحنين

تم وضع الملف تحت الاختبار فمع تانى قيد تم ادخاله ظهر الخطأ التالى بالملف

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

لااعلم لماذا ؟

اعلم انى ارهقتك اعانك الله على طلباتنا

ارجو التطبيق على المرفق

سعد عابد3.rar

[الفرس]

الاخ الكريم / محمود

 

القيد يكتب بلغة المحاسبين من طرفين منفصلين شرط التوازن بالشكل التالى :

 

1000 ح / م العمومية

2000 ح / التشغيل

3000 ح / الحسابات المدينة

                                 3000 ح / البنوك

                                 3000 ح / الخزينة

 

لاحظ ان الطرفين لم يكونا امام بعضهما

 

اتبع نفس الشكل فى التطبيق وسيتم الترحيل بالطريقة السليمة

 

ولك تحياتى

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

لا تزال المشكله قائمه ( الكود لا يقرأ اللغه العربيه صحيحه يقرأها علامه استفهام ؟؟؟؟؟؟؟؟؟؟؟؟ ) 

 

مع العلم هناك اكواد اخرى تقرأ اللغه العربيه صحيحه بجهازى

 

الملف مرفق بالمشاركه 14#

 

هي مكتوبة في الكود بهذا الشكل ؟؟؟؟؟؟؟؟؟؟؟؟

 

لقد نسخت الكود من المشاركة 9 والصقته بدلا من الموجود

اشتغل عادي

المرفق 2003

سعد عابد2.rar

[ابو اياد ( الاسيوطى )]

السلام عليكم

الاستاذه الكبار عباقره المنتدى

بارك الله فيكم على تعبكم معى ، ولكن حتى الان لم نصل الى الحل السليم للترحيل

استذنا واستاذ الجميع // عبد الله باقشير

استاذنا الكبير // ابو حنين

اخى العزيز// الفرس

ارجو التركيز على المرفق بالمشاركه 38#

 

انتظركم

[الفرس]

الاخ / محمود

السلام عليكم

فعلا بالتركيز وجدت الكود لايعمل بشكل صحيح من تانى قيد

[أبو حنــــين]

السلام عليكم

اخي محمود جرب هذا التعديل

 

سعد عابد 4.rar

[ابو اياد ( الاسيوطى )]

استاذنا الكبير // ابو حنين
 
بارك الله فيك ومشكور على تعبك معى وسعه صدرك للوصول الى ما نريد
الترحيل تمام يتم بشكل سليم 100% من وجه نظرى بناءا على حاله قاعده البيانات المبالغ
( كانت هناك ملحوظه هى كان يتم ترحيل المبالغ دون توجيهها على اسم حساب )
 
تم تلافى هذا الخطأ عن طريق وضع شرط اخر لعدم الترحيل وهو ( G6>0 ) تدل على ان هناك مبلغ لم يتم توجيهه على حساب بعينه

Sub saad()


Application.ScreenUpdating = False
Sheets("Entry").Select
al = Sheets("Database").[e10000].End(xlUp).Row
If [d1] = "" Or [d2] = "" Or [d3] = "" Or [G6] > 0 Then
MsgBox "Ãßãá ÇáÈíÇäÇÊ ÃæáÇ"
Exit Sub
ElseIf Not [c4].Value = [d4].Value Then
MsgBox "ÊÃßÏ ãä ÇÏÎÇá ÇáÞíÏ ãÚ ÊæÇÒä ÇáØÑÝíä", vbExclamation, "ÇÏÎÇá ÎÇØÆ"
Exit Sub
ElseIf Sheets("Database").Range("e" & al).Value = [d2].Value Then
MsgBox "ÊÃßÏ ãä ÚÏã ÊßÑÇÑ ÇáÞíÏ", vbExclamation, "ÇÏÎÇá ÎÇØÆ"
Exit Sub
End If
If MsgBox("åá ÊÑíÏ ÊÑÍíá ÇáÈíÇäÇÊ ÇáÍÇáíÉ", vbInformation + vbOKCancel, "ÊÑÍíá") = vbCancel Then Exit Sub
With Sheets("Entry")
R_C = .Cells(Rows.Count, "C").End(xlUp).Row: R_D = .Cells(Rows.Count, "D").End(xlUp).Row
R_E = .Cells(Rows.Count, "E").End(xlUp).Row: R_F = .Cells(Rows.Count, "F").End(xlUp).Row
R_Row = Application.WorksheetFunction.Max(R_C, R_D, R_E, R_F)
End With
With Sheets("Database")
Last = .Cells(Rows.Count, "G").End(xlUp).Row + 2
.Range("D" & Last - 1 & ":J" & Last - 1).Interior.ColorIndex = 33
.Rows(Last - 1 & ":" & Last - 1).RowHeight = 7
x = Last
For R = 7 To R_Row
Sheets("Entry").Range("C" & R).Resize(1, 4).Copy
.Range("G" & x).PasteSpecial xlPasteValues: .Range("D" & x) = Sheets("Entry").Range("D1").Value
.Range("E" & x) = Sheets("Entry").Range("D2").Value: .Range("F" & x) = Sheets("Entry").Range("D3").Value
x = x + 1
Next
End With
With Sheets("Database")
Last1 = .Cells(Rows.Count, "D").End(xlUp).Row
.Range("D" & Last1 & ":J" & Last1).Borders.Value = 1
.Range("D" & Last1 & ":J" & Last1).Borders(xlEdgeTop).LineStyle = xlNone
.Range("D" & Last1 & ":J" & Last1).Borders(xlEdgeBottom).Weight = xlThick
.Range("D" & Last1 & ":J" & Last1).Borders(xlEdgeBottom).ColorIndex = 3
End With
With Sheets("Entry")
MsgBox "Êã ÊÑÍíá ÈíÇäÇÊ ÇáÓäÏ ÑÞã   " & .Range("D2") & "   ÈäÌÇÍ", vbInformation, "ÊÑÍíá"
.Range("C7:F40") = ""
.Range("D1:D3") = ""
End With
Application.ScreenUpdating = True
Application.CutCopyMode = False





End Sub

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

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

 

الترحيل الان يتم بشكل سليم والحمد لله 

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

 

( ولكنى كنت اود ان امحو هذا الصف الفارغ )

 

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

 

بارك الله فيك وتقبل تحياتى

سعد عابد 5.rar

[أبو حنــــين]

السلام عليكم

جرب هذا التعديل

سعد عابد 6.rar

[ابو اياد ( الاسيوطى )]

ابو حنين 

انت انسان رائع

[أبو حنــــين]

اخي محمود

و انت اروع لانك لم تيأس و قررت الوصول ويبدو و الله اعلم انك قد وصلت

[ابو اياد ( الاسيوطى )]

 

الحمد لله الذى بنعمته تتم الصالحات

 

 

استاذى الكبير // ابو حنين

لا اجد ما اقوله من كلمات على صبرك معى وعلى تعديلاتى الكثيره وعلى سعه صدرك

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

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

وطبعا استاذى العزيز // سعد عابد على اجتهاده الموفق فى عمل الكود

 

استاذى العزيز // ابو حنين

اتمنى منكم فى وقت فراغ او وقتما تريد

وانا غير مستعجل تماما على هذا الطلب

شرح الكود سطر سطر كى يتسنى لى فهمه

تقبل احر تحياتى وحبى وتقديرى لكم

 

تلميذكم // الاسيوطى

[الفرس]

الاخ الكريم ابوحنين

 

جزاكم الله خيرا على المجهود الرائع

 

والشكر كل الشكر للاخ العزيز / محمود