اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

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


ميلان
إذهب إلى أفضل إجابة Solved by سليم حاصبيا,

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

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

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

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

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

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

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

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

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

WhatsApp Image 2020-12-17 at 6.13.23 PM.jpeg

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

تم تعديل بواسطه 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

  • Like 3
رابط هذا التعليق
شارك

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

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

  • Like 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

  • Like 2
  • Thanks 1
رابط هذا التعليق
شارك

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

  • Like 1
رابط هذا التعليق
شارك

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

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

رابط هذا التعليق
شارك

  • أفضل إجابة

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

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

  • Like 1
رابط هذا التعليق
شارك

من فضلك سجل دخول لتتمكن من التعليق

ستتمكن من اضافه تعليقات بعد التسجيل



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

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information