سؤال بخصوص طباعة شيتات

[بكار للأبد]

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

عندي ملف به حوالي 330 اسم في شيت اسمه data يتقاضي كل منهم مبلغ معينة في أشهر معينة على مدار العام وعملت شيت آخر فيه نموزج واحد استعنت فيه بدالة Vlookup وخانة بحث وبمجرد اختيار الاسم تظهر بيانات الموظف على نفس النموزج بدلاً من عمل شيت لكل موظف .
السؤال هنا - عند طباعة صفحات كل الموظفين مرة واحدة او عدد معين ، فهل هناك فكرة لطباعة كل الموظفين او بعضهم مرة واحدة بدلاً من اختيار موظف موظف وطباعته وهذا مرهق جداً .؟
الملف مرفق

كلمة السر 500
كلمة السر الداخلية 123
وبالمرة هل ممكن حماية المعادلات المستخدمة من التلف او الرؤية ؟ ومعرفة كيف اقدر استعادتههم وتعديلهم عند الحاجة
 

الحد الأقصى نهائي معدل 2018.rar

[shreif mohamed]

وعليكم السلام تفضل 

قم بالضغط علي زر

print_all

الحد الأقصى نهائي معدل 2018.xlsm

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

بمكنك استعمال هذا الماكرو ( في احر سطرين قبل  Next  اختر او طباعة او معاينة قبل الطباعة) و ذلك بحذف الفاصلة العليا أمام ما تريد

عند تنقيذ الماكرو تظهر لك رسالتين الرسالة الاول ابتداءً من الاسم (الاول)   

                                               الرسالة الثانية حتى الاسم (الاخير)

تضع الاسم من الجدول تماماً كما هو دون مسافات زائدة او ناقصة (الافضل اخذ الاسم Copy / Paste)

لا مشكلة في الترتيب (اذا كان اول اسم مثلاُ رقمه 15 والثاني 5) اكسل يرتبها بحيث يكون الاول 5 والثاني 15

Option Explicit

Sub Print_out()
  Dim S_Sh As Worksheet: Set S_Sh = Sheets("DATA")
  Dim Targ_sh As Worksheet: Set Targ_sh = Sheets("Sew_Sheet")
  Dim x%, y%, t1%, t2%, i%
  Dim First_Name$, Second_Name$
  
  First_Name$ = Application.InputBox("give the first name", Type:=2)
  Second_Name = Application.InputBox("give the seconde name", Type:=2)
  First_Name = Application.Trim(First_Name)
  Second_Name = Application.Trim(Second_Name)
  
  x = Application.Match(First_Name, S_Sh.Range("a:a"), 0)
  y = Application.Match(Second_Name, S_Sh.Range("a:a"), 0)
  
  t1 = Application.Min(x, y): t2 = Application.Max(x, y)
   For i = t1 To t2
     Targ_sh.Cells(3, 2) = S_Sh.Range("a" & i)
     '=======================================
      'Choose Here print Or print previvew
   '  Targ_sh.PrintPreview
   '  Targ_sh.PrintOut
    '=========================================
   Next
End Sub

 

 

[بكار للأبد]

الأخ الفاضل شريف محمد جزاك الله كل خير على المجهود الرائع .

الاستاذ المحترم سليم حاصيبا الكود أكثر من رائع كالمعتاد ، ولكنه يظهر فقط عندما اعمل تشغيل للماكرو الخاص به في محرر الأكواد ، فهل  أطمع سيدي الكريم في تركيبه لي لاني ركبته في الورك شيت ومابيشتغلش غير لما عمل رن للاماكرو من داخل محرر الأكواد فهل يمكن تركيبه لي  وتخصيصه بحيث أختار عدد الصفحات التي أريد طبعها او كلها - وجزيل الشكر لشخصك الكريم المتواضع . 

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

يجب وصع الماكرو في موديل مستقل و ليس في الوورك شيت

لذلك امسحه من مكانه و ضعه في موديل مستقل

[بكار للأبد]

سيدي الفاضل سليم حاصيبا : وضعت الكود في موديول مستقل كما وجهتني سيادتكم ولكنه ما زال لا يعمل الا في وضع الvba ، فهل أطمع على استحياء في وضعه لي بحيث يظهر عند فتح الملف او عند الحاجة اليه من الخارج ، وهل يمكن اختيار عدد معيبن من الموظفين لطباعتهم بدلا من كتابة اسم اسم .

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

تم معالجة الامر (بواسطة ارقام الخلايا في عامود الاسماء) فقط اكتب البداية في الخلية H4  والنهاية في الخلية H5 في الشيت "sew sheet"
واضغط الزر Run

لا حاجة لكتابة الاسماء في الماكرو السايق (فقط من اسم كذا الى اسم كذا) حسب الجدول

الكود

Option Explicit

Sub Print_out()
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
.Calculation = xlCalculationAutomatic
End With
  Dim S_Sh As Worksheet: Set S_Sh = Sheets("DATA")
  Dim Targ_sh As Worksheet: Set Targ_sh = Sheets("Sew_Sheet")
  Dim x%, y%, t1%, t2%, i%

  Targ_sh.Unprotect

  x = Targ_sh.[h4]: y = Targ_sh.[h5]
  
  t1 = Application.Min(x, y): t2 = Application.Max(x, y)
  If t1 <= 1 Then t1 = 2
   For i = t1 To t2
     Targ_sh.Cells(3, 2) = S_Sh.Range("a" & i)
     '=======================================
      'Choose Here print Or print previvew
     Targ_sh.PrintPreview
   '  Targ_sh.PrintOut
    '=========================================
   Next
   With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
.Calculation = xlCalculationAutomatic
End With
Targ_sh.Protect
End Sub

 

 

 

الحد الأقص Salim new.xlsm

[بكار للأبد]

ممكن سيدي الفاضل إعادة رفع الملف ، حيث انه يبدو انه لم يرفع جيداً

تم تعديل أبريل 5, 2018 بواسطه بكار للأبد

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

2 ساعات مضت, بكار للأبد said:

ممكن سيدي الفاضل إعادة رفع الملف ، حيث انه يبدو انه لم يرفع جيداً

 اليك الملف من جديد

 

الحد الأقص Salim new.xlsm

[بكار للأبد]

كلمات الشكر تعجز عن شكرك سيدي الكريم ، لكن جزاك الله كل خير وأثابك الجنة ، وجمعنا وإياكم في الجنة أخوة على سرر متقابلين