ميلان قام بنشر ديسمبر 17, 2020 مشاركة قام بنشر ديسمبر 17, 2020 (معدل) كل الشكر الى هذا المنتدى الرائع وخصيصا الى الاستاذ الكبير الرائع @سليم حاصبيا الذي ساعدني كثيرا في هذا الملف وأود التعديل عليه بعد تغيير في نظام العمل لدى المخيم وهذا العمل مجاني بالكامل ولوجه الله تعالى الملف الاستاذ سليم قد برمج الكود لاستدعاء 8 فواتير دفعه واحدة المطلوب الان 1 - تعديله ليصبح يستدعي فاتورة واحدة 2 -اضافة زر طباع كما هو موضح بالصورة 3 - عند طابعه فاتورة ان يتغير لون الصف بغير لون لتمييزه في الشيت الاساسي 4 - اضافة عامود في اول شيت باسم فاقد الشبكة لترحيل القيمة للفاتورة وكل الشكر لجميع الاصدقاء حاولت انا ولكن فشلت وفي طريق التعلم منكم اخوتي في الله كل الحب والاحترام مخيم باب السلام.xlsm تم تعديل ديسمبر 17, 2020 بواسطه Muhammed syr نسيت امر مهم رابط هذا التعليق شارك More sharing options...
سليم حاصبيا قام بنشر ديسمبر 17, 2020 مشاركة قام بنشر ديسمبر 17, 2020 تم وضع الكود اللازم 1- الكود يعطي معاينة قبل الطياعة 2- لجعله يطبع مباشرة استبدل ما موجود في الكود بين علامات اليساوي "============" بــ B.PrintOut Option Explicit Dim S As Worksheet Dim B As Worksheet Dim last%, Ro%, i% Dim dic As Object Dim Mon_array Dim Itm '++++++++++++++++++++++++++++++++ Sub Fatura_One() Set S = Sheets("Source") Set B = Sheets("By_one") Set dic = CreateObject("Scripting.Dictionary") last = S.Cells(Rows.Count, 1).End(3).Row S.Range("A4").Resize(last, 9).Interior.ColorIndex = xlNone For i = 4 To last If Not IsEmpty(S.Cells(i, 2)) Then S.Cells(i, 1).Resize(, 9).Interior.ColorIndex = 35 Mon_array = Application.Transpose _ (S.Cells(i, 1).Resize(, 9)) Mon_array = Join(Application.Transpose(Mon_array), "*") dic(dic.Count) = Mon_array End If Next If dic.Count Then For Each Itm In dic.items() B.Range("E6").Resize(9) = _ Application.Transpose(Split(Itm, "*")) '========================== B.PrintPreview '======================== Next End If Set dic = Nothing End Sub الملف مرفق Bab Salam.xlsm 3 رابط هذا التعليق شارك More sharing options...
ميلان قام بنشر ديسمبر 17, 2020 الكاتب مشاركة قام بنشر ديسمبر 17, 2020 @سليم حاصبيا استاذنا الكبير سليم حاصيبا كلمة شكر لا اتكفي بحقك كل الشكر والاحترام لك سلمت يداك فعلت المطلوب واكثر شكرا جزيلا لك اخي في الله واستاذي الكبير استاذنا الكبير @سليم حاصبيا هناك مشكلة لوتفضلت علي بالوقت عندما اضع رقم الفاتورة واضغط run يقوم بطابعة من رقم 1 والى نهاية الملف والمطلوب هو طباعه فقط الرقم الذي استدعيه وشكرا جزيلا لك 1 رابط هذا التعليق شارك More sharing options...
سليم حاصبيا قام بنشر ديسمبر 17, 2020 مشاركة قام بنشر ديسمبر 17, 2020 انت لم تذكر هذا الشيء في سؤالك ساعمل على ما تريد (ماكرو آخر) 1 رابط هذا التعليق شارك More sharing options...
ميلان قام بنشر ديسمبر 17, 2020 الكاتب مشاركة قام بنشر ديسمبر 17, 2020 @سليم حاصبيا انا حقا اسف استاذي الكريم ظننت اني اوصلت الفكرة الصحيحة اعتذر منك فعلا وشكرا لجهودك سبقا استاذي الكريم كل المحبة لك رابط هذا التعليق شارك More sharing options...
سليم حاصبيا قام بنشر ديسمبر 17, 2020 مشاركة قام بنشر ديسمبر 17, 2020 تم انشاء ماكرو يقوم يهذا العمل (Print_Only _One) 1-اذا كانت الخلية H5 تحتوي على عدد اكبر من المطلوب ( يعني عدد المشتركين او عدد الأسماء) او عدد سالب او صفر او فارغة فأن الماكرو يسجلها 1 وبالتالي يستخرج أول مشترك 2- الماكرو بعمل على عدد المشتركين (مثلاً اذا كتبت 4 في الخلية H5 فإن الماكرو بستحرج رايع مشترك وليس الصف رفم 4) 3- الماكرو القديم ما زال يعمل في حال اردت طباعة الكل دفعة واحدة Option Explicit Dim S As Worksheet Dim B As Worksheet Dim last%, i%, Nb% Dim dic As Object Dim Mon_array Dim Itm Dim rg As Range '++++++++++++++++++ 'Other macro to Ptint One fatura Sub Fatura_Only_One() Set S = Sheets("Source") Set B = Sheets("By_one") Set dic = CreateObject("Scripting.Dictionary") last = S.Cells(Rows.Count, 1).End(3).Row S.Range("A4").Resize(last, 9).Interior.ColorIndex = xlNone For i = 4 To last If Not IsEmpty(S.Cells(i, 2)) Then Mon_array = Application.Transpose _ (S.Cells(i, 1).Resize(, 9)) Mon_array = Join(Application.Transpose(Mon_array), "*") dic(dic.Count) = Mon_array End If Next If dic.Count Then If Val(B.Range("H5")) <= 0 Or _ Val(B.Range("H5")) > dic.Count Then B.Range("H5") = 1 Else B.Range("H5") = Int(B.Range("H5")) End If Nb = Int(B.Range("H5")) - 1 B.Range("E6").Resize(9) = _ Application.Transpose(Split(dic.Items()(Nb), "*")) Set rg = S.Range("B1:B" & last).Find(B.Range("E7"), lookat:=1) If Not rg Is Nothing Then S.Cells(rg.Row, 1).Resize(, 9).Interior.ColorIndex = 35 End If '========================== B.PrintPreview ' '======================== End If Set dic = Nothing End Sub Bab Salam_New.xlsm 2 1 رابط هذا التعليق شارك More sharing options...
ميلان قام بنشر ديسمبر 17, 2020 الكاتب مشاركة قام بنشر ديسمبر 17, 2020 شكرا شكرا استاذي الكريم على مجهودك الرائع كل المحبة والاحترام لك جزاك الله خير الجزاء واوسع معرفتك ♥️♥️♥️♥️ 1 رابط هذا التعليق شارك More sharing options...
abouelhassan قام بنشر ديسمبر 17, 2020 مشاركة قام بنشر ديسمبر 17, 2020 بارك الله فيك استاذ سليم وجزاك خيرا عنا شكر وتقدير واحترام رابط هذا التعليق شارك More sharing options...
ميلان قام بنشر ديسمبر 21, 2020 الكاتب مشاركة قام بنشر ديسمبر 21, 2020 @سليم حاصبيا استاذنا الكبير اعلم اني قد تماديت في الطلب لكن بعد استعمال الكود تبين انه عند طباعه الفاتور يتغير لونها وعند طباعه فاتورة اخرى يعود لونها بدون تعبئة ولم استطع تمييز الفواتير المدفوعة المرجو انه عند طباعه فاتورة ان يتغير لونها ويبقى ثابت لتميزهم وسؤال اخر بعد انتهاء الشهر كيف اعيد الشت بدون تعبئة لاعيد استخدامه في الشهر القادم وجزاك الله كل خير واوسع علمك ومعرفتك وكل الاحترام رابط هذا التعليق شارك More sharing options...
سليم حاصبيا قام بنشر ديسمبر 21, 2020 مشاركة قام بنشر ديسمبر 21, 2020 ارفع الملف من جديد لاني مسحته من الجهاز عندي لعدم حاجتي اليه رابط هذا التعليق شارك More sharing options...
ميلان قام بنشر ديسمبر 21, 2020 الكاتب مشاركة قام بنشر ديسمبر 21, 2020 @سليم حاصبيا Bab Salam_New.xlsm رابط هذا التعليق شارك More sharing options...
أفضل إجابة سليم حاصبيا قام بنشر ديسمبر 21, 2020 أفضل إجابة مشاركة قام بنشر ديسمبر 21, 2020 تم تنزيل الملف مرة ثانية والتعديل على الكود 1- عند طباعة الفاتورة يتغير لونها و يدرج في العامود K تاريخ الطياعة 2- اذا اردت طباعتها مرة احرى تحصل على رسالة تفيد انه تم طباعتها مسيقاً والرسالة تعطيك حيار الطباعة مرة اخرى او لا 3- عندما تريد (عند نهاية الشهر مثلاً) اضغط الزر New Month لتمسح التواريخ و ترجع الألوان الى طبيعتها Option Explicit Dim S As Worksheet Dim B As Worksheet Dim last%, i%, Nb% Dim dic As Object Dim Mon_array Dim Itm Dim rg As Range Dim Answer As Byte '++++++++++++++++++ 'Other macro to Ptint One fatura Sub Fatura_Only_One() Set S = Sheets("Source") Set B = Sheets("By_one") Set dic = CreateObject("Scripting.Dictionary") last = S.Cells(Rows.Count, 1).End(3).Row For i = 4 To last If Not IsEmpty(S.Cells(i, 2)) Then Mon_array = Application.Transpose _ (S.Cells(i, 1).Resize(, 9)) Mon_array = Join(Application.Transpose(Mon_array), "*") dic(dic.Count) = Mon_array End If Next If dic.Count Then If Val(B.Range("H5")) <= 0 Or _ Val(B.Range("H5")) > dic.Count Then B.Range("H5") = 1 Else B.Range("H5") = Int(B.Range("H5")) End If Nb = Int(B.Range("H5")) - 1 B.Range("E6").Resize(9) = _ Application.Transpose(Split(dic.Items()(Nb), "*")) Set rg = S.Range("B1:B" & last).Find(B.Range("E7"), lookat:=1) If Not rg Is Nothing Then S.Cells(rg.Row, 1).Resize(, 9).Interior.ColorIndex = 35 End If If S.Cells(rg.Row, "K") Like "Printed On:*" Then Answer = MsgBox("هذه الفاتورة تمت طباعتها مسبقاُ" & Chr(10) & _ "هل تريد الطباعة مرة ثانية", 1048644) If Answer <> 6 Then GoTo End_me End If S.Cells(rg.Row, "K") = "Printed On:" & Date '========================== B.PrintPreview ' '======================== End If End_me: Set dic = Nothing End Sub الملف مرفق Bab Salam_Super.xlsm 1 رابط هذا التعليق شارك More sharing options...
ميلان قام بنشر ديسمبر 21, 2020 الكاتب مشاركة قام بنشر ديسمبر 21, 2020 جزاك الله كل خير استاذي الكريم لقد اوفيت الغرض شكرا لك ولجهودك استاذي @سليم حاصبيا رابط هذا التعليق شارك More sharing options...
الردود الموصى بها
من فضلك سجل دخول لتتمكن من التعليق
ستتمكن من اضافه تعليقات بعد التسجيل
سجل دخولك الان