فضلا *** تعديل كود جمع وتلحيق - سعيد بيرم

[أبو عبد الرحمن سعيد]

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

وبه نستعين

الاخوة الاعزاء

السلام عليكم ورحمته الله وبركاته

الكود التالى يعتمد على عدة عوامل منها عملية الجمع بالكشف الاول

وتلحيق هذا الجمع مع بداية الكشف الثانى وهكذا باقى الكشوف

وذلك من خلال الضغط على الزر F2  من لوحة المفاتيح

علما بأن الكود ليس به أدنى مشكلة تذكر حيث تبدأ عملية الجمع من العمود E الى العمود AC

ولكن مع تقليص عدد الاعمدة لكى تبدأ عملية الجمع والتلحيق من العمود N الى العمود W

يحدث خلل بظهور رسالة خطأ 

لذا نرجو التفضل بتعديل الكود على نحو تبدأ عملية الجمع والتلحيق من العمود N الى العمود W

والى حضراتكم المرفق التالى

المراد تعديله لكى تبدأ عملية الجمع والتلحيق من العمود N الى العمود W

وافر تقديرى واحترامى وجزاكم الله خيرا

Sub Copeir_Tebel() 'لنسخ الجدول ايضا بنفس ارتفاع الصفوف
Dim sh As Worksheet: Set sh = Sheets("data")
Dim sh2 As Worksheet: Set sh2 = Sheets("مكافاة الثانوية العامة")
Dim lr As Long: lr = sh2.Cells(sh2.Rows.Count, 1).End(xlUp).Row + 2
Dim i As Integer

    sh2.Rows("28:28").Copy
    sh2.Range("A" & lr + 4).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
       sh2.Rows("8:28").Copy
       sh2.Range("A" & lr + 5).Select
       ActiveSheet.Paste
       Application.CutCopyMode = False

Dim Lrw As Long: Lrw = sh2.Cells(sh2.Rows.Count, 2).End(xlUp).Row
Dim x As Integer: x = sh2.Range("A" & lr - 3) + 1
      For i = lr + 5 To Lrw - 1
      sh2.Range("A" & i) = x
      x = x + 1
      Next
Dim MyString As String, sXXXX As String
Dim lID As Long
    MyString = sh2.Range("A" & lr - 2)
    lID = Mid(MyString, 8, Len(MyString))
    sXXXX = Mid(MyString, 1, 7)
    sh2.Range("A" & lr + 4) = "الكشف " & lID
    sh2.Range("A" & Lrw + 1) = sXXXX & lID + 1
      ActiveSheet.PageSetup.PrintArea = "$A$1:$AD" & Lrw
Dim Str As Byte: Str = 34
    FinalRow = Range("A65536").End(xlUp).Row
    For i = Str To FinalRow Step 27
    ActiveSheet.Cells(i, 1).Select
    ActiveSheet.HPageBreaks.Add before:=Cells(i, 1)
    Next i
End Sub

تم تعديل أبريل 2, 2015 بواسطه سعيد بيرم

[ياسر خليل أبو البراء]

الأخ الحبيب سعيد

جرب الكود بهذا الشكل ..

Sub Copeir_Tebel() 'لنسخ الجدول ايضا بنفس ارتفاع الصفوف
Dim sh As Worksheet: Set sh = Sheets("data")
Dim sh2 As Worksheet: Set sh2 = Sheets("مكافاة الثانوية العامة")
Dim lr As Long: lr = sh2.Cells(sh2.Rows.Count, 1).End(xlUp).Row + 2
Dim i As Integer
Dim Rw1 As Long, Rw2 As Long, Rw3 As Long
    Rw1 = lr + 4
    sh2.Rows(lr - 2 & ":" & lr - 2).Copy
    sh2.Range("A" & Rw1).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
       sh2.Rows("8:28").Copy
       sh2.Range("A" & lr + 5).Select
       ActiveSheet.Paste
       Application.CutCopyMode = False

Dim Lrw As Long: Lrw = sh2.Cells(sh2.Rows.Count, 2).End(xlUp).Row
Dim x As Integer: x = sh2.Range("A" & lr - 3) + 1
      For i = lr + 5 To Lrw
      sh2.Range("A" & i) = x
      x = x + 1
      Next
Rw2 = Lrw: Rw3 = Lrw + 1
        sh2.Cells(Rw3, 14).Formula = "=IF(SUM(N" & Rw1 & ":N" & Rw2 & ")=0,"""",SUM(N" & Rw1 & ":N" & Rw2 & "))"
        sh2.Cells(Rw3, 14).Select
        Selection.AutoFill Destination:=Range("N" & Rw3 & ":W" & Rw3), Type:=xlFillDefault
        sh2.Range("N" & Rw3 & ":W" & Rw3).Select

Dim MyString As String, sXXXX As String
Dim lID As Long
    MyString = sh2.Range("A" & lr - 2)
    lID = Mid(MyString, 12, Len(MyString))
    sXXXX = Mid(MyString, 1, 11)
    sh2.Range("A" & lr + 4) = "ماقبله جملة كشف " & lID
    sh2.Range("A" & Lrw + 1) = sXXXX & lID + 1
      ActiveSheet.PageSetup.PrintArea = "$A$1:$X" & Lrw
Dim Str As Byte: Str = 34
    FinalRow = Range("A65536").End(xlUp).Row
    For i = Str To FinalRow Step 27
    ActiveSheet.Cells(i, 1).Select
    ActiveSheet.HPageBreaks.Add before:=Cells(i, 1)
    Next i
End Sub

وشوف النتائج صحيحة كما تتوقعها ..

تقبل تحياتي

تم تعديل أبريل 2, 2015 بواسطه YasserKhalil

[أبو عبد الرحمن سعيد]

 

 اخى العزيز الفاضل الاستاذ // ياسر خليل " ابوالبراء "

اشكرسيادتكم على اهتمامكم البالغ بالموضوع 

وعلى مايبدو أنه " راحت علينا " فقد تبين الخطأ الذى تتطرقت اليه ولكن

كان هناك خطأ أخر منى فى " : " والحمدلله على كل حال

بارك الله فيكم وبارك فى البراء

ورزقكم الله وإيانا من حيث لانحتسب

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

اسمح لى أولا بهذه الاضافة الهامة لما لها من مغذى

وقتما يسمح لك وقتك بإضافتها

 ألا وهى عملية التفقيط  فلكل عمل هدف معين

اسمح لى بهذا التوضيح

بشأن عملية التفقيط هنا وحتى لايكون هناك اى تلاعب من اى نوع وخاصة

ممن ليس لهم أدنى ضميرفى مجال عملهم وتجنبا لحدوث مالا يحمد عقباه

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

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

مثالا على ذلك

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

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

أما لو هناك أكثر من كشف ولنعتبر ان هناك 3 ثلاثة كشوف جاهزه للطباعة فيجب هنا تجاهل التفقيط بالكشف

الاول ومن ثم يأتى التفقيط نهاية الكشف الثالث رقم 3

فهل من سبيل لتحقيق هذا الامرالهام نظرا لما فى كشوف الصرف الورقية من عوار

حيث يسهل من خلالها على ممن تسول لهم أنفسهم بأمورغير حميده

من شأنها إهدارالمال العام لمصلحتهم الشخصية

ارجو أن أكون وضحت لسيادتكم المطلوب

الله أسأل أن يوفقكم وإيانا لما يحب ويرضى  

بارك الله فيك واسعدك فى الدارين 

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

 

تم تعديل أبريل 2, 2015 بواسطه سعيد بيرم

[سـامي 169]

استاذ سعيد

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

برنامج للمرتبات خاص برجال التربيه والتعليم

انت أدها

[بن علية حاجي]

السلام عليكم ورحمة الله

 

أخي الحبيب سعيد، أعتقد أن الحيلة لإضافة التفقيط أسفل آخر كشف يكون عند عملية الطباعة فقط، بمعنى أن يضاف كود للطباعة يقوم أولا بإضافة عملية التفقيط قبل طباعة الكشوف، ثم طباعة الكشوف بالتفقيط في آخر كشف، ثم يقوم بحذف التفقيط المضاف تحسبا للعمليات الأخرى (إضافة كشوف أخرى وغيرها)... والله أعلم

 

أرجو أن تصل الفكرة جيدا...

 

 

أخوك بن علية

[سـامي 169]

الاخ سعيد

لم ترد علينا

[سـامي 169]

ايه الفرق بين هذا الموضوع وهذا الرابط

http://www.officena.net/ib/index.php?showtopic=60306

[أبو عبد الرحمن سعيد]

الاخ العزيز الاستاذ // سامى

السلام عليكم

الفرق بين الموضوعين

الاول والذى نحن بصدده على تلك الصفحة ان الملف يعمل على نظام الخانة الواحده

اما الثانى الموضوع مختلف حيث يعتمد الموضوع على نظام الخانتين 

 وكلاهما صحيح من حيث النتائج

والاختيارهنا حسب ماتقتضية ظروف العمل 

اما بشأن برنامج المرتبات فلدينا حزمة برامج كامله من تنفيذى

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

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

 بحول الله تعالى .... وافراحترامى وتقديرى

تم تعديل أبريل 4, 2015 بواسطه سعيد بيرم

[سـامي 169]

 

الاخ العزيز الاستاذ // سامى

السلام عليكم

اما بشأن برنامج المرتبات فلدينا حزمة برامج كامله من تنفيذى

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

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

 بحول الله تعالى .... وافراحترامى وتقديرى

 

وعليكم السلام ورحمة الله وبركاته

كل يوم فيه جديد ولو انتظرنا الجديد من القوانين لن نتقدم ولن نعمل شيئا

ولذلك ارجو ان تشرفنا برنامج كامل

ندعو لك

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