أبو إيمان

يمكن الاطلاع على الرابط يمكن يفيدك إن شاء الله
 
https://www.officena.net/ib/topic/20819-ترحيل-الى-صفحة-آخرى-على-حسب-لون-الخلية/
 
https://www.officena.net/ib/topic/53328-ترحيل-اعمده-معينة-بناء-على-لون-خليه-فى-عمود-معين/
 
كما يمكنك الاطلاع على الرابط التالي أيضا 
 

وعليكم السلام ورحمة الله وبركاته
تفضل حل متواضع بالمعادلات
ويمكن التنفيذ للحل بالأكواد يمكن البحث داخل المنتدى عن استدعاء وترحيل البيانات
نموذج أوفيسنا 002.xlsm

استخدم المعادلة التالية باعتبار أن الرقم القومي في الخلية B3
=DATEDIF(DATE(IF(LEFT(B3;1)*1=3;20;19)&MID(B3;2;2);MID(B3;4;2);MID(B3;6;2));TODAY();"y") حيث يتم تقسيم الرقم القومي إلى شهر وسنة وأيام وبعدها يتم طرحه من اليوم الحالي today  واظهار الناتج بالسنة y

لقد حاولت 
وبفضل الله نجح الامر معي 
والشكر لجميع أعضاء المنتدى الشكر موصول للأخ Lionhear
Option Explicit Sub Get_Data_From_Closed_Workbooks() Dim a, wb As Workbook, ws As Worksheet, sFile As String, sPath As String, lr As Long, m, x, y, z As Long Application.ScreenUpdating = False sPath = ThisWorkbook.Path & "\" & "تقارير" & "\" sFile = Dir(sPath & [k6] & "*" & ".xlsx") m = 9 With Sheet12.Range("b8").CurrentRegion.Offset(1) .ClearContents: .Borders.Value = 0 End With Do While sFile <> "" Set wb = Workbooks.Open(sPath & sFile, ReadOnly:=True) Set ws = wb.Sheets(1) With ws lr = .Cells(Rows.Count, "b").End(xlUp).Row a = .Range("b9:o" & lr).Value x = [c6] y = [e6] z = [h6] .Parent.Close False End With Sheet12.Range("b" & m).Resize(UBound(a, 1), UBound(a, 2)).Value = a m = m + UBound(a, 1) sFile = Dir() Loop With Sheet12.Range("b9:o" & m - 1) .Borders.Value = 1 End With [c6] = x [e6] = y [h6] = z End Sub  

بعدد إذن الاخ كريم  وإثرائا للموضوع 
جرب هذا البرنامج ABBYY Fine Reader أستخدمه منذ فترة  وكان يأتي على اسطوانة التعريفات مع بعض الماسحات الضوئية  والميزة يسمح بالتصدير الى صيغ متنوعة وأيضا يسمح بالتحويل من الماسح الضوئي أو ماكينة التصوير مباشرة
ممتاز جدا 
يحول الانجليزي بكفاءة عالية جدا مع أخطاء لا تكاد تذكر 
ويحول العربي أيضا لكن قد يختلف بعض التنسيقات 
ولكن قد يحدث خطأ في بعض الصور في الملف 

وعليكم السلام ورحمة الله وبركاته
إليك هذا الملف يمكن يفيدك إن شاء الله الفكرة قريبة من كشوف مناداة اللجان في الاختبارات
وهذا يمكن طباعته يدويا ويمكن اضافة كود لطباعة الكل تلقائيا
 
مناداة ولجان لجنة.xls

بخصوص التأمين للنسخة الجديد 
يمكن وضع السطر التالي في بداية الكود
ActiveSheet.Protect Password = "Jokem"  
والسطر التالي في نهاية الكود
ActiveSheet.unProtect Password = "Jokem"  
أما بخصوص أن تكون النسخة الجديدة بلا أكود فهذه النقطة يمكن لاحد العمالقة تنفيذها

وعليكم السلام ورحمة الله وبركاته
لاخفاء شريط الصيغة 
Application.DisplayFormulaBar = False إليك هذا الكود يخفي جميع الاشرطة ويجعل الوضع ملء الشاشة ويقوم بإخفاء تبويب أوراق العمل 
لاحظ الصفحة المراد أن تفتح عليها   ( يمكن وضع الكود في حدث فتح المصنف _ الملف _ ) 
 
Range("a1").Select Application.ScreenUpdating = False Dim ws As Worksheet Sheet1.Visible = xlSheetVisible For Each ws In ThisWorkbook.Worksheets If Not ws.Name = "اكتب هنا اسم الصفحة التي تريد ظهورها اول شيء" Then ws.Visible = xlSheetVeryHidden Next ws ActiveWindow.DisplayHeadings = False Application.DisplayFormulaBar = False Application.ExecuteExcel4Macro "SHOW.TOOLBAR(""Ribbon"",false)" Application.ActiveWindow.DisplayWorkbookTabs = False  

حضرتك لا يوجد في الملف الرقم 12 لكي يتم تغييره المكتوب 12.5 القيمة الصغرى 

والكود لا يعتمد على قيم ثابته فالكود يعمل بحسب القيم المدخلة في الخلية C5 , D5 , E5
وإليك شرح الكود 
Sub replace() 'يتم مقارنة اذا كانت القيمة الجديدة أكبر من القيمة القديمة If [e5] > [d5] Then 'اوجد رقم اخر صف يحتوي على بيانات lr = [B10000].End(xlUp).Row ' عمل حلقة تكرارية بدايتها رقم أول عمود ونهايتها اخر اعمود For y = 2 To 9 ' يختبر مكان وجود المادة If Cells(8, y).Value = [c5] Then 'حلقة تكرارية اخرى بدايتها أول صف يحتوي على بيانات ونهايتها اخر صف For x = 9 To lr 'يحدد أين تقع القيمة المراد استبدالها (القيمة القديمة ) If Cells(x, y).Value = [d5] Then 'يستبدل القيمة التي عثر عليها بالقيمة الجديدة Cells(x, y).Value = [e5] End If Next End If Next End If End Sub  
وكما تلاحظ في الشرح لم يتم الربط بقيم ثابته 
 

مرحبا بك في أي وقت 
الاكواد كما يلي 
طباعة الصفحة الحالية  ( صفحة واحدة ) 
Sub print_1() ActiveWindow.SelectedSheets.PrintOut From:=1, to:=1, Copies:=1, Collate _ :=True, IgnorePrintAreas:=False End Sub  
طباعة كل الموظفين  ( ولعمل ذلك تم عمل عمود مساعد لوضع رقم مسلسل للموظفين )
Sub print_1() ActiveWindow.SelectedSheets.PrintOut From:=1, to:=1, Copies:=1, Collate _ :=True, IgnorePrintAreas:=False End Sub Sub print_all() ' الاعلان عن متغير من النوع الرقمي الصحيح Dim x As Integer 'عمل حلقة تكرارية بديتها القيمة الموجودفي في الخلية ام 3 وتنتهي في الخلية ام 4 For x = [m3] To [m4] 'أمر الطباعة ActiveWindow.SelectedSheets.PrintOut From:=1, to:=1, Copies:=1, Collate _ :=True, IgnorePrintAreas:=False ' زيادة القيمة في الخلية بمقدار 1 للانتقال للشخص التالي [m3] = [m3] + 1 ' تكرار التنفيذ Next [m3] = 1 End Sub  
إذا كنت لا ترغب في العمود المساعد يمكنك عمل الرقم الوظيفي قائمة منسدلة ويمكنك الاطلاع على الرابط التالي 
 
الكود في الأساس للاستاذ بن عليه حاجي على ما أتذكر ( فقط تم توظيفه ليناسب طلب السائل )
 
الاداة التي تنقل بين أرقام الموظفين ( أداة تحكم )  لا يوجد بها كود فقط يمكن ضبطها من خلال خصائصها 
 

 
 
 
 
 
طباعة الكل ومفرد.xlsm

وعليكم السلام ورحمة الله وبركاته
يمكنك استخدام خاصية البحث او الضغط على الرابط وسوف تجد الكثير من المواضيع المرتبطة بالمرتبات واذا لم تجد طلبك في البحث فضلا ارفاق ملف كمثال لما تريد
https://www.officena.net/ib/search/?q=مرتبات&quick=1&type=forums_topic&nodes=135

على اي تاريخ سوف تعتمد وهل تعتمد يوم ما في الشهر أم كل بيانات الشهر

بعد إذن أخونا محمد يوسف 
 
قم بتجربة الكود في الملف التالي والذي سوف يقوم بالحفظ كملف PDF بشكل تلقائي لكل الأسماء الموجودة في القائمة المنسدلة الموجودة في الخلية D3
 
 
بيات توزيع المواد الغذائية 002.xlsm

جرب المرفق
 
حالة الطالب ناجح - برنامج علاجي 002.xlsx
 

إذا كنت تريد عدم الطباعة يمكن كتابة احد الصيغ التالية  وبجوار End sub نكتب 30
On Error Resume Next ActiveWindow.SelectedSheets.PrintOut Copies:=Range("a1"), Collate:=True, _ IgnorePrintAreas:=True أو If Range("a1") = 0 Then GoTo 30 ActiveWindow.SelectedSheets.PrintOut Copies:=Range("a1"), Collate:=True, _ IgnorePrintAreas:=True End If واذا كنت تريد طباعة نسخة على الاقل يمكنك كتابة التالي
If Range("a1") = 0 Then ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _ IgnorePrintAreas:=True Else ActiveWindow.SelectedSheets.PrintOut Copies:=Range("a1"), Collate:=True, _ IgnorePrintAreas:=True End If  
 

وعليكم السلام ورحمة الله وبركاته 
يمكن ذلك من خلال أداة التحكم ( التي تقوم بالضغط عليها لاظهار ملصقات اخر ) بالضغط على الأداة بزر الفأرة الأيمن ثم اختر Format control  ثم من تبويب control أمام incremental change  اكتب الرقم 14 ولا تنسى حذف الملصقات الزائدة من اسفل 

Private Sub Workbook_Open() Dim ws As Worksheet Sheet"الرئيسية".Visible = xlSheetVisible Sheet"الرئيسية".Select Range("a1").Select For Each ws In ThisWorkbook.Worksheets If Not ws.Name = "الرئيسية" Then ws.Visible = xlSheetVeryHidden Next ws Application.ScreenUpdating = true End Sub  

معادلة ترحيل يعمل مع أي اصدار
test001.xlsm

الملف المرفق لاحد الاعضاء 
يوجد به أكواد للترحيل والاستدعاء يمكننك الاستفادة منه في موضوعك 
كود ترحيل واستدعاء.xlsm

بعد اذن الاستاذ ياسر 
أخي الفاضل هذا كود قد قدمه لي الاستاذ القدير رجب جاويش مع بعض التعديلات عليه
Sheets("æÑÞÉ1").PageSetup.RightHeader = Sheets("æÑÞÉ5").Range("d5").Value & vbCr & _ Sheets("æÑÞÉ5").Range("d6").Value & vbCr & _ Sheets("æÑÞÉ5").Range("d7").Value قم بوضعه في حدث الورقة أو زر خاص

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

تفضل أخي المرفق التالي لعله يفي بالغرض
اختصار 001.rar

أتمنى من الله أن أكون وفقت في تنفيذ المطلوب لك والشرح الوافي
 
 
وإليك الحل بطريقة أخرى
اظهار اسم مستخدم الويندوز في مربع رسالة001.rar

أخي الفاضل يمكنك عمل هذا بإحدى الطرق
1- عمل عدد 31 شيت منهم 30 للإدخال و1 للتجميع
2- أن تقوم بإدخال كافة التواريخ في نفس الشيت وتقوم بإدخال البيانات وبعد تقوم بعمل تصفية حسب التاريخ وتطبع ما تريد
 
وأكيد هناك أفضل مما أطرح عليك عند الاساتذة لكن مقترحي مبدئي 
والله الموفق