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

وعليكم السلام ورحمة الله وبركاته
كود ترحيل التغيير من الوصل الى السجل.xlsm

لم انتبه لذلك فعذرا 
شكرا لدعائك واطرائك  
الملف
 
بحث بجزء من الإسم (1).xlsb

السلام عليكم
 جربت  الكود  أحمد -إبراهيم  -إسلام -آية- أيمن - الادارية-الإدارية - ادارة   سميرة -شئ - وغيرهاكلها يالهمز وبدون همز  شغال 100%
الكود بقوم بالتغاضى عن :
جمبع  حروف الالف لاي كلمة بالقتح او بالكسر يتم البحث عنها سواء كتبتها بالهمز او بدونه
جمبع حروف الياء لاي كلمة عند البحث لو كتبنها الف مقصورة   ى   يتم احضار قيمتها
كذلك كلمة  شئ مثلا او ما في حكمها عند البحث لو كتبنها شى  بدون همزة يتم احضار قيمتها
كذلك اي كلمة فيها ة عند البحث لوكتبتها ه يتم احضار قيمتها
وسواء كان الحروف السابقة كانت في اي موقع من الكلمة في بداية او وسط او نهاية الكلمة  يقوم باحضار قيمتها
كذلك اذا كانت الكلمة حروفها لا تتكرر مع كلمة اخرى مثلا كلمة إبراهيم  لو كتبت في البحث هيم يحضر قيمتها
كذلك الكود مرن يمكن اظافة اي حروف للكود تريد اهمالها عند البحث
    str = Replace(str, "أ", "ا")
    str = Replace(str, "إ", "ا")
    str = Replace(str, "آ", "ا")
    str = Replace(str, "ي", "ى")
    str = Replace(str, "ئ", "ي")
    str = Replace(str, "ة", "ه")
ارفق لك الملف مرة اخرى ولم اغير شيئا بالكود
اصدار الاوفيس لدي 2016 وحسب علمى الكود متوافق مع كل الاصدرات
بحث حتى لو فى اخلاتف بسيط1.xls
 
 
 

وعليكم السلام ورحمة الله وبركاته
 حسب المعادلة في ملفك يمكن استبدالها بمعادلة اخرى لها نفس المهام
=SUMPRODUCT(C4:AA4; C$3:AA$3) طبعا لا يمكن لصقها مكان معادلة الصفيف الا بطريقة تظلبل معادلات الصفيف في العمود بالكامل ثم مسح البيانات  تم لصق المعادلة
الملف
المصنف1.xlsx
 

https://excelnoob.com/vba-password-remover/

نفضل كود الطباعة
سرى الشهادة الاعدادية (2).xlsb

وعليكم السلام ورحمة الله وبركاته
بدون ارفاق ملف ندخل  في باب الاحتمالات اما .... واما
الرسالة المعروضة تعني أن هناك عنصرًا (مثل ActiveX أو مكون في UserForm كـ ListBox أو ComboBox او غيره) في النموذج الخاص بك  اوفي الاكواد غير متوفر على جهازك. 
بمكنك معرفة الكائن او المكتبة الغير متوفرة من خلال :-
1- الكود 
2- او الانتقال إلى Developer > Visual Basic > Tools > References    
اذا وجدت كلمة MISSING  (بمعنى مفقود)  المكتوب امام الكلمة هي المكتبة المفقودة  الصورة المرفقة كمثال لمكتبة مفقودة
3- الغاء التاشير من كلمة  MISSING  قد يحل المشكلة احيانا وليس دائما
اتمنى ان اكون قدمت  لك ما يقيد
لك وافر التقدير والاحترام

 

وعليكم السلام ورحمة الله وبركاته
المعادلة 
=SUMIFS(C:C; B:B; ">=" & DATE($E$4;1;1); B:B; "<=" & DATE($E$4;12;31)) الملف
جمع القيم بناء على السنة.xlsx
 
وفقكم الله

السلام عليكم ورحمة الله وبركاته 
جرب المعادلة
=IF(AND(B2=0; A2>0); A2 + 1; IF(AND(B2>=1; A2=0); 0; IF(AND(B2>=1; A2>0); A2 - B2; A2))) الملف
المصنف1.xlsx

جربى الملف المرفق  وفيه حالة نفس المرتب
المعايير التى بنى عليها الكود هي :-
 
المقارنة بين المرتبات:
يقوم الكود بمقارنة المرتب الرسمي لكل موظف بين الملفين، ويضيف النتيجة إلى العمود H في ملف المقارنة:
زيادة في المرتب: إذا كان المرتب في الملف الثاني أكبر من المرتب في الملف الأول.
نقص في المرتب: إذا كان المرتب في الملف الثاني أقل من المرتب في الملف الأول.
نفس المرتب: إذا كان المرتب في الملفين متساويًا.
محذوف: إذا كان اسم الموظف موجود في الملف الأول ولكن غير موجود في الملف الثاني.
جديد: إذا كان اسم الموظف موجود في الملف الثاني ولكن غير موجود في الملف الأول.
نتائج المقارنة.xlsb
وهذا الملف خاص بمن زادت او نقصت او حذفو او جددفقط  بدون نفس المرتب 
نتائج المقارنة1.xlsb

وعليكم السلام ورحمة الله وبركاته
=CEILING(G14*E14; 1) بالتوفيق

نعم يمكن ذلك الملف به 3 اكواد 
عمل المعادلات بكود1.xlsb

السلام عليكم ورحمة الله وبركانه
صبحكم الله بالخير
جرب الملف وان لم يكتمل حدد ما هو المطلوب
لك وافر التقدير والاحترام
نقل أعمدة محددة من ورقة الى أكثر من ورقة+222222.xlsm

وعليكم السلام ورحمة الله وبركاته
لو ارفقت لنا ملفك لاختصرت الوقت او ارفقت الجملة التى بها خطأ لسهلت لنا الامر
يدون ملف محاولات قد تصيب وقد تخطئ
ريما السبب من جملة  FILESEARCH والتي اعتقد انها غير متوافقة مع الاصدارات بعد 2003 ( غير متاكد منها)
سنفترض ان الامر منها فيكون تعديل الكود كالتالى
Private Sub FrstChnge(combo1 As ComboBox, combo2 As ComboBox) Dim val As String Dim Namey As String Dim fso As Object Dim folder As Object Dim file As Object combo2.Clear If combo1.Value = "" Then MsgBox "الرجاء اختيار شيت من القائمة", vbExclamation Exit Sub End If val = ThisWorkbook.Path & "\" & combo1.Value & "\Ser" Set fso = CreateObject("Scripting.FileSystemObject") If fso.FolderExists(val) Then Set folder = fso.GetFolder(val) For Each file In folder.Files If LCase(fso.GetExtensionName(file.Name)) = "xlsx" Then Namey = file.Name Namey = Left(Namey, Len(Namey) - 5) ' إزالة الامتداد .xlsx combo2.AddItem Namey End If Next file Else MsgBox "المجلد غير موجود: " & val, vbExclamation End If Set fso = Nothing Set folder = Nothing Set file = Nothing End Sub   او جرب الكود التالى 
Private Sub FrstChnge(combo1 As ComboBox, combo2 As ComboBox) Dim val As String Dim filePath As String Dim fileName As String val = combo1.Value combo2.Clear If val = "" Then Exit Sub filePath = ThisWorkbook.Path & "\" & val & "\Ser\" fileName = Dir(filePath & "*.xls*") Do While fileName <> "" combo2.AddItem Left(fileName, Len(fileName) - 4) fileName = Dir Loop End Sub اذا لم بعمل ارفق ملفك 
وفقك الله
 

وعليكم السلام ورحمة الله وبركاته
تم عمل كود بدل معادلات الصفيف  والترتيب الكود ينظر الى السنة اولا  بمبن العلامة المائلة ثم يبحث عن اصغر رقم يسارا
تم عمل قائمة اختيار  لاختيار N° Bordereau وكلما اضفت رقما اضيف الى القائمة
لك كل الاحترام والتقدير
 
BORDEREAU FACILE1.xlsm

جرب الكود التالى النتيجة فى G2 بمكن تعديلها فى الكود
Sub CalculateResult() Dim cellCount As Long Dim result As Variant Dim dataRange As Range Dim cell As Range Set dataRange = Sheets("طباعة").Range("B7:I11") cellCount = 0 For Each cell In dataRange If cell.Value <> 0 And cell.Value <> "" Then cellCount = cellCount + 1 End If Next cell Select Case Sheets("طباعة").Range("F2").Value Case "الأول", "الثانى" If cellCount >= 25 Then result = 25 Else result = cellCount End If Case "الثالث" result = cellCount Case Else result = "" End Select Sheets("طباعة").Range("G2").Value = result MsgBox "تم حساب النتيجة: " & result الملف
 
عدد الخلايا بشروط.xlsx

الملف المعدل 
سبق معالجة الامر حيث يتم مسح البيانات قبل استدعاء التواريخ       ws.Range(ws.Cells(7, 49), ws.Cells(8, Columns.Count)).ClearContents
تم التعدبل  حبث يتعامل مع اخر صف به اسم موظف زاد العدد او نقص واذا اردت الغاء موظف احذف الصف بالكامل لو امسحه بالكامل      ws.Range("AU9:CM" & lastRow).ClearContents
تم التعديل  الصف الذى به بيانات يتم مسح التنسيقات
ws.Range("AU" & lastRow + 1 & ":CM" & ws.Rows.Count).ClearFormats
انمتى ان تجد طلباتك فى هذا الملف وان هناك اي شئ غير مكتمل فابلغنى فان لم اكن انا فالكثير من اعضاء المنتدى يقدمون المساعدة
المهم الحصول على طلبك  وليس المهم من قام به
برعاية الله وحفظه
استدعاء التاريخ أفقيا +11111.xlsm
 

السلام عليكم 
حسب طلبك
اكتب فى A1 الصف الذى تربد البحث فيه 
واكتب فى A2  رقم عمود البيانات الذى تربد البحث فيه
نتيجة البحثت جدها فى A3
يمكنك البحث فى نفس العمود او غيره
تحياتى
=INDIRECT(ADDRESS(A1; A2)) بحث في اي صف او عمود.xlsb

قمت بعمل مثال لك بفصل الحالات الثلاتة كما طلبت
 الكود
Sub FilterValues() Dim ws As Worksheet Set ws = ThisWorkbook.Sheets("Sheet1") Dim lastRow As Long lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row ws.Range("G2:H" & ws.Cells(ws.Rows.Count, "G").End(xlUp).Row).ClearContents ws.Range("I2:J" & ws.Cells(ws.Rows.Count, "I").End(xlUp).Row).ClearContents ws.Range("K2:L" & ws.Cells(ws.Rows.Count, "K").End(xlUp).Row).ClearContents Dim negArr() As Variant Dim posArr() As Variant Dim zeroArr() As Variant Dim i As Long, negCount As Long, posCount As Long, zeroCount As Long Dim dataRange As Range Set dataRange = ws.Range("B2:C" & lastRow) Dim dataArr As Variant dataArr = dataRange.Value ReDim negArr(1 To UBound(dataArr, 1), 1 To 2) ReDim posArr(1 To UBound(dataArr, 1), 1 To 2) ReDim zeroArr(1 To UBound(dataArr, 1), 1 To 2) negCount = 0 posCount = 0 zeroCount = 0 For i = 1 To UBound(dataArr, 1) Select Case dataArr(i, 2) Case Is < 0 negCount = negCount + 1 negArr(negCount, 1) = dataArr(i, 1) negArr(negCount, 2) = dataArr(i, 2) Case Is > 0 posCount = posCount + 1 posArr(posCount, 1) = dataArr(i, 1) posArr(posCount, 2) = dataArr(i, 2) Case Else zeroCount = zeroCount + 1 zeroArr(zeroCount, 1) = dataArr(i, 1) zeroArr(zeroCount, 2) = dataArr(i, 2) End Select Next i ws.Range("G2").Resize(negCount, 2).Value = Application.Index(negArr, Evaluate("ROW(1:" & negCount & ")"), Array(1, 2)) ws.Range("I2").Resize(posCount, 2).Value = Application.Index(posArr, Evaluate("ROW(1:" & posCount & ")"), Array(1, 2)) ws.Range("K2").Resize(zeroCount, 2).Value = Application.Index(zeroArr, Evaluate("ROW(1:" & zeroCount & ")"), Array(1, 2)) End Sub الملف
فصل الدائن والمدين والصفرية الى اعمدة جديدة.xlsb

الكود بضاف في حدث الورقة  بدون زر وبوجد ملفك وبه الكود فى المشاركة السابقة
حمل الملف واذا كان الماكرو غير مفعل فقم بتفعيله تمكبن المحتوى
بعد فتح الملف اكتب فى العمو دC كلمة البحث فقط تاتى لك بالنسبة%
الملف مرة اخرى وشغال 100%
بحث بجزء من الجمله1.xls

السلام عليكم  ورحمة الله وبركاته
صباح الخير 
الاستاذ سعيد بما اننا  في نفس العمر تقريبا 61 سنة    واشتراكنا بالمنتدى تقريبا فى نفس السنة بفارق عام اهديك هذا الملف  مع تحياتنا الخالصة لاخينا الاستاذ محمد هشام وادعو الله ان يمدكما بطول العمر ويمتعكما  بالصحة وراحة البال والرزق الوفير
بمكن كتابة تاريخ البدابة والتهاية يدوبا  في L2 -N2  فتتم العملية
الزر في الصفحة اخنياري ولبس اساسى مهمته انك تكتب تاربخ البداية بدويا ثم تكتب عدد الايام المراد اظافتها الى التاريخ في N3 ثم اضغط على الزر فبظفها الى تاريخ النهاية 
تحياتى لكما ولكل اخوتنا في هذا المنتدى
انقسام الشهور على قائمتبن.xlsm
 
 

وعليكم السلام ورحمة الله وبركاته 
الاستاذ محمد هشام  في المشاركة السابقة  اخبرك  (في حالة كنت تستخدم إصدار قديم  لن تشتغل معك الصيغ. أخبرني بذالك لمحاولة إنشاء دالة أو كود vba ينفذ نفس المهمة) 
حسب ملفك الحالى كود في حدث الورقة كلما تم التغيير في M2  يتم التغيير في الاعمدة
الملف
أيام الشهر من يوم محدد - vba (1).xlsm

وعليكم السلام ورحمة الله وبركاته
 
الكود
Sub ExtractAbsentees() Dim ws As Worksheet Dim lastRow As Long, lastCol As Long Dim i As Long, j As Long Dim outputRow As Long Set ws = ThisWorkbook.Sheets("SHEET1") lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row lastCol = ws.Cells(4, ws.Columns.Count).End(xlToLeft).Column outputRow = 5 For i = 5 To lastRow For j = 4 To lastCol If ws.Cells(i, j).Value = "A" Then ws.Cells(outputRow, 15).Value = ws.Cells(i, 2).Value ws.Cells(outputRow, 16).Value = ws.Cells(4, j).Value outputRow = outputRow + 1 End If Next j Next i End Sub الملف
الغياب.xlsb

السلام عليكم 
اذاكانت الملفات المرتبطة عددها بسيط استخدم الطريقة اليدوية التالية
فتح الملف الرئيسي:
افتح ملف Excel الرئيسي الذي يحتوي على الروابط إلى الملفات الأخرى. تحرير الروابط:
اذهب إلى علامة التبويب "البيانات" (Data) في الشريط. اضغط على "تحرير الروابط" (Edit Links) التي توجد عادة في مجموعة "الاتصالات" (Connections). تغيير مصدر الروابط:
ستظهر لك نافذة تحتوي على جميع الروابط الموجودة في الملف. حدد الروابط التي تحتاج إلى تحديث، ثم اضغط على "تغيير المصدر" (Change Source). اختيار الموقع الجديد:
اختر الملفات من الموقع الجديد الذي تم نقلها إليه. تحديث الروابط:
بعد اختيار الملفات، اضغط على "موافق" لتحديث الروابط إلى الموقع الجديد. اذ كانت الروابط كثيرة فاستخدم الكود التالى
Sub UpdateLinks() Dim OldLink As String Dim NewLink As String Dim LinkArray As Variant Dim i As Integer ' الرابط القديم OldLink = "C:\المسار_القديم\" ' الرابط الجديد NewLink = "C:\المسار_الجديد\" LinkArray = ActiveWorkbook.LinkSources(Type:=xlExcelLinks) If Not IsEmpty(LinkArray) Then For i = LBound(LinkArray) To UBound(LinkArray) If InStr(LinkArray(i), OldLink) > 0 Then ActiveWorkbook.ChangeLink Name:=LinkArray(i), NewName:=Replace(LinkArray(i), OldLink, NewLink), Type:=xlExcelLinks End If Next i End If MsgBox "تم تحديث الروابط بنجاح!", vbInformation End Sub قم بتعديل المسارات (OldLink و NewLink) حسب الموقع القديم والجديد للملفات.

المعادلة 
=IF(B2="";"";IF(B2<=C2;2%;"1%")) الملف
تحقق التارحت.xlsx