عبدالله بشير عبدالله

جرب التعديل التالي
توزيع عدد الحصص (233) (1).xlsm

السلام عليكم 
نعم المشكلة من حماية الشيتات
 اليك التعديل مع اظافة الترقيم التلقائي لرقم التسجيل
Plateform (1) .xlsb
 
 
 

اليك  التعديل
Plateform (1).xlsb
 
 

اليك التعديل 
Plateform.xlsb

السلام عليكم 
تم عمل الاحصائيات  
الملف المرفق به الاحصاء  
Plateform3.xlsb
الشريط المتحرك ليس لدي جلفية لعملة ولا اراه مهما لانه سيسبب ثقل للملف
ا1ذا تحققت طلباتك ارجو فتح موضوع جديد  لاي طلب جديد وهذا حسب قوانين المنتدى

وعليكم السلام ورحمة الله وبركاته
اليك التعديل المطلوب 
Horaire1.xlsb

اولا / الملف السابق به كودين كلاهما معاينة تم تعديل احدهما الى طباعة
ثانيا  :- للتطبيق على ملفك / احعل لغة الجهاز العربية وانسخ الكود المرفق وفي ملفك الاخر قم بالدخول إلى صفحة الفيجوال بيسك عن طريق التبويب Developer(المطور) ثم Visual Basic    ثم من قائمة Insert  اختر  Module  والصقه  به واربطه بزر في الصفحة المراد ترقيمها
ملاحطة/ الكود المرفق مهمته الطباعة مع الترقيم
ان اردت المعاينة مع الترقيم بدون طباعة غير  كلمة FALSE الى TRUE في الجملة   ws.PrintOut From:=i, To:=i, Preview:=False
Sub طباعة() Dim ws As Worksheet Dim totalPages As Long Dim i As Long Dim pageNum As Integer Set ws = ActiveSheet totalPages = (ws.HPageBreaks.Count + 1) * (ws.VPageBreaks.Count + 1) For i = 1 To totalPages pageNum = Application.WorksheetFunction.RoundUp(i / 2, 0) If i Mod 2 <> 0 Then ws.PageSetup.CenterFooter = "الصفحة " & Format(pageNum, "00") Else ws.PageSetup.CenterFooter = "تابع الصفحة " & Format(pageNum, "00") End If ws.PrintOut From:=i, To:=i, Preview:=False Next i End Sub  

وعليكم السلام ورحمة الله وبركاته .
ارى الحل في الغاء جميع معادلات الصفيف واالابقاء على الاسماء في النطاق AA16:AA  وبدل المعادلات كود في حدث الورقة
ملاحظة هامة 
اذا اردت نقل الكود الى ملف اخر به الكمبوبكس1 يجب اجراء بعض التعديلات على اعدادات الكمبوبكس1
افتح الكمبوبكس في وضع التصميم  ثم خصائص تم امسخ البيانات في الدائرة الحمراء كما في الصورة  كذلك قم بمسخ المعادلات 

تقبل الله صيامكم وطاعاتكم
حل مشكل القائمة المنسدلةباستخدام ComboBox1.xlsm

وعليكم السلام ورحمة الله وبركاته
الحل هو نقل الكود إلى موديول (Module) عادي وتخصيص زر  لتشغيله فقط عندما تضيف أوراق عمل جديدة
اليك التعديل بالمرفق
المصنف2.xlsm
 
 

جرب التعديل التالي 
 
لا ننس كتابة اسم الملف في الحلية A2
الكل (1) (2).xlsm
لا حرج ان اردت اي تعديل احر

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

وعليكم السلام ورحمة الله وبركاته
 اليك الملف وبه كود المعاينة
ملف الحجز.xlsb

التصفية في ورقة جديدة
1تصفية.xlsb

السلام عليكم
حسب ما فهمته من طلبك المعادلة التالية تلبى المطلوب 
ضع المعادلة في l2 ثم اسحبها الى اسفل
=IFERROR(VLOOKUP(K2; $O:$P; 2; FALSE); "")  

السلام عليكم ورحمة الله وبركاته
حل بالكود وان  اضفت مواد احرى عدل النطاق في الكود
Sub ProcessAndSumData() Dim wsB As Worksheet Set wsB = ThisWorkbook.Sheets("B") Application.ScreenUpdating = False With wsB .Range("B10:I12").ClearContents With .Range("B10:I10") .FormulaR1C1 = "=IFERROR(SUMPRODUCT((A!R3C1:R1828C1=R6C3) * (ISNUMBER(INDEX(A!R3:R1828,0,MATCH(R8C,A!R1,0)))) * (INDEX(A!R3:R1828,0,MATCH(R8C,A!R1,0))>=60)),""/"")" .Value = .Value End With With .Range("B11:I11") .FormulaR1C1 = "=IFNA(SUMPRODUCT((INDEX(A!R3:R1828,0,MATCH(R8C,A!R1,0))<60) * ISNUMBER(INDEX(A!R3:R1828,0,MATCH(R8C,A!R1,0))) * (A!R3C1:R1828C1=R6C3)),""/"")" .Value = .Value End With With .Range("B12:I12") .FormulaR1C1 = "=SUM(N(R[-2]C), N(R[-1]C))" .Value = .Value End With End With Application.ScreenUpdating = True End Sub لا تنس تفعيل الماكرو
aa2.xlsb
 

وعليكم السلام ورحمة الله وبركاته
حسب فهمى لطلبك انك تقصد بالعمود الثالت  العمود A 
يناء   عليه اليك معادلة صعها بداية من D2 ثم اسحبها لاسفل  او ضغها في عمود بداية من الصف2
=INDEX($B$2:$B$500;MATCH(A2; $C$2:$C$500; 0))  ارجو ان يكون في ردي ما يفيد
تحياتي

وعليكم السلام ورحمة الله وبركاته
جرب الملف واعلمنى بالنتيجة
ملف الحجز.xlsb

السلام عليكم ورحمة الله وبركاته\
الطلب الاول
  
ملف الحجز.xlsb
اذا تحقق طلبك في الملف المرفق احتر تمت الاجابة وافتح موضوع جديد بطلبك الاحر به شرح واضح للطلب  وستجد من يقدم المساعدة للحل  وانا منهم
تحياني
 
 

ربما  يكون احد الاسباب  وكما احبرتك في ردي الاحير باننى لست جازما وحصوصا ان الملف في مشاركتك الاولى يعمل لدي وكذلك حسب استاذتا  Foksh ان الملف يعمل لديه
وربما يكون مسار سطح المكتب هو السبب
تم تعديل الكود وسيطلب منك مكان حفظ الملف احتر اي مكان 
جرب واعلمنى بالنتائج
مرتب +عمولة السائقين (2).xlsm
 

نعم الامر هكذا واضح وقمت بحذف التعليق السابق لعدم اهميته بعد ارفاق ملفك الاخير وبه التوضيح
جرب الكود  
Sub تجميع() Dim ws As Worksheet Dim آخرصف As Long Dim c As Long, r As Long Dim صف_الاخراج As Long Set ws = ActiveSheet صف_الاخراج = 1 ws.Columns(16).ClearContents For c = 1 To 13 آخرصف = ws.Cells(ws.Rows.Count, c).End(xlUp).Row For r = 1 To آخرصف If ws.Cells(r, c).Value <> "" Then ws.Cells(صف_الاخراج, 16).Value = ws.Cells(r, c).Value صف_الاخراج = صف_الاخراج + 1 End If Next r Next c End Sub  

اليك الملف
البحث في القائمة بالحروف.xlsm

وعليكم السلام ورحمة الله وبركاته
 
هل تعنى انك لا تريد ظهور الواجهة  لاحتيار الملف وتريد الاستيراد مباشرة 
اليك الملف بدون ظهور الواجهة  ويكون الملفان في مكان واحد وبنفس الاسماء
اضغط على زر استيراد يتم احضار البيانات مباشرة
ملف.zip
 

السلام عليكم 
السبب هو وجود مسافات قبل الارقام وهذا يحدث عادة عند نسح ارقام ناتجة عن معادلات
 
الحل  كل القيم تتحول إلى نصوص (CStr) وتُزال الفراغات (Trim)  وهذا يضمن التطابق حتى لو كانت القيم أرقام أو نصوص أو ناتجة عن معادلات.
اليك الكود المعدل
Sub تحويل_اللجان_الى_اسماء_Turbo() Dim ws As Worksheet: Set ws = ActiveSheet Dim r As Long, c As Long Dim lastRowMain As Long, lastRowSearch As Long Dim رقم_اللجنة As String, اسم_اللجنة As String, اسم_المراقب As String Dim فارق_الاعمدة As Long: فارق_الاعمدة = 12 Dim cell As Range lastRowSearch = ws.Cells(ws.Rows.Count, "N").End(xlUp).Row ws.Range("P3:X" & lastRowSearch).ClearContents lastRowMain = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row lastRowSearch = ws.Cells(ws.Rows.Count, "N").End(xlUp).Row For r = 3 To lastRowMain اسم_المراقب = Trim(CStr(ws.Cells(r, "B").Value)) For c = 4 To 12 رقم_اللجنة = Trim(CStr(ws.Cells(r, c).Value)) If رقم_اللجنة <> "" Then For Each cell In ws.Range("C3:C" & lastRowMain) If Trim(CStr(cell.Value)) = رقم_اللجنة Then اسم_اللجنة = Trim(CStr(ws.Cells(cell.Row, "B").Value)) Dim صف_المراقب As Range For Each صف_المراقب In ws.Range("N3:N" & lastRowSearch) If Trim(CStr(صف_المراقب.Value)) = اسم_المراقب Then ws.Cells(صف_المراقب.Row, c + فارق_الاعمدة).Value = اسم_اللجنة Exit For End If Next صف_المراقب Exit For End If Next cell End If Next c Next r End Sub  

جرب التعديل التالي
test2.xlsm

وعليكم السلام ورحمة الله وبركاته
فكرة pdf انه يقوم بانشاء صفحة مؤقتة بها اسماء الموظفين وكل موظف قي ورقة ثم يصدرها الى pdf  قم يحذف الورقة
عدد الموظفين لديك حوالى 350 موظف 
بمعنى يتم انشاء حوالى 350 ورقة
المقصود مما سبق دكره ان الكود سيأحد بعض الوقت لتنفيذ الامر ويعتمد الامر على مواصفات الجهاز 
بالنسبة لجهازي تطلب الامر دقيقة ونصف بمواصفات في حدود الجيدة
اليك الملف
 
مرتب الفنيين عن شهر يناير 2026 تعديل.xlsm