نعديل كود ترحيل واضافة زر طباعه

[ميلان]

كل الشكر الى هذا المنتدى الرائع وخصيصا الى الاستاذ الكبير الرائع @سليم حاصبيا الذي ساعدني كثيرا في هذا الملف وأود التعديل عليه بعد تغيير في نظام العمل لدى المخيم وهذا العمل مجاني بالكامل  ولوجه الله تعالى 

الملف الاستاذ سليم قد برمج الكود لاستدعاء 8 فواتير دفعه واحدة المطلوب الان 

1 - تعديله ليصبح يستدعي فاتورة واحدة 

2 -اضافة زر طباع كما هو موضح بالصورة 

3 - عند طابعه فاتورة ان يتغير لون الصف بغير لون لتمييزه في الشيت الاساسي 

4 - اضافة عامود في اول شيت باسم فاقد الشبكة لترحيل القيمة للفاتورة 

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

كل الحب والاحترام 

مخيم باب السلام.xlsm

تم تعديل ديسمبر 17, 2020 بواسطه Muhammed syr
نسيت امر مهم

[سليم حاصبيا]

تم وضع الكود اللازم

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

[ميلان]

  @سليم حاصبيا   استاذنا الكبير سليم حاصيبا كلمة شكر لا اتكفي بحقك كل الشكر والاحترام لك سلمت يداك فعلت المطلوب واكثر شكرا جزيلا لك اخي في الله واستاذي الكبير 

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

[سليم حاصبيا]

انت لم تذكر هذا الشيء في سؤالك

ساعمل على ما تريد (ماكرو آخر)

[ميلان]

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

[سليم حاصبيا]

تم انشاء ماكرو يقوم يهذا العمل   (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

[ميلان]

شكرا شكرا استاذي الكريم على مجهودك الرائع كل المحبة والاحترام لك جزاك الله خير الجزاء واوسع معرفتك ♥️♥️♥️♥️

[abouelhassan]

بارك الله فيك استاذ سليم وجزاك خيرا عنا

شكر وتقدير واحترام

[ميلان]

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

وسؤال اخر بعد انتهاء الشهر كيف اعيد الشت بدون تعبئة لاعيد استخدامه في الشهر القادم وجزاك الله كل خير واوسع علمك ومعرفتك وكل الاحترام 

[سليم حاصبيا]

ارفع الملف من جديد لاني مسحته من الجهاز عندي  لعدم حاجتي اليه

[ميلان]

@سليم حاصبيا

Bab Salam_New.xlsm

[سليم حاصبيا]

تم تنزيل الملف مرة ثانية والتعديل على الكود

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

[ميلان]

جزاك الله كل خير استاذي الكريم لقد اوفيت الغرض شكرا لك ولجهودك استاذي @سليم حاصبيا