ياسر خليل أبو البراء

إخواني الكرام في المنتدى الغالي
 
أقدم لكم اليوم موضوع ليس بالجديد ولكنه جد مفيد (جد .. يعني جداً أوك يا جدو) ..أقصد مفيد جداً
 
الموضوع يتمحور ويتمركز حول معرفة الأرقام المفقودة أو الأرقام الناقصة في سلسلة أرقام ..
 
إليكم الكود الأول المؤدي للغرض (هنا يشترط ترتيب الأرقام) ، مع شرح تفصيلي لأسطر الكود لتتمكن من التعديل عليه
Sub MissingNumber_NumbersSorted() 'يقوم الكود بإظهار الأرقام الناقصة في تسلسل معين للأرقام ويشترط ترتيب الأرقام '-------------------------------------------------------------------------     Dim SH As Worksheet     Dim LR As Long     Dim Text As String     Dim I As Long, X As Long, XX As Long      '[Sheet1] تخصيص المتغير ليساوي ورقة العمل المسماة     Set SH = Sheets("Sheet1") 'تحديد آخر صف به بيانات في العمود الأول     LR = SH.Cells(SH.Rows.Count, 1).End(xlUp).Row 'حلقة تكرارية بداية من الصف الخامس وحتى آخر صف به بيانات في العمود الأول     For I = 5 To LR 'يساوي الفرق بين قيمة الخلية التالية وقيمة الخلية الحالية في الصف المحدد [X] المتغير         X = Val(SH.Range("A" & I + 1)) - Val(SH.Range("A" & I)) '[X] استخدام الجملة الشرطية لناتج المتغير         Select Case X 'إذا كان الفرق بين قيمة الخليتين أكبر من 1 يتم تنفيذ الحلقة التكرارية ما بين السطرين             Case Is > 1 'حلقة تكرارية لتخزين الأرقام الناقصة                 For XX = 2 To X 'يساوي المتغير نفسه مع قيمة الخلية الحالية مضاف إليها قيمة المتغير في الحلقة التكرارية ناقص واحد ثم سطر جديد[Text]المتغير المسمى 'مثال لفهم هذا السطر '------------------- 'توجد القيمة 50012 [A15] توجد القيمة 50009 وفي الخلية [A14] في الخلية 'بما أن الفرق بين الخليتين يساوي 3 إذاً سيتم تنفيذ الحلقة التكرارية 'بداية الحلقة التكرارية 2 حيث أن رقم 2 هو أول رقم أكبر من واحد ، وفي مثالنا نهاية الحلقة التكرارية تساوي 3 'المتغير المفترض تخزين الأرقام الناقصة فيه عبارة عن سلسلة نصية فيتم إضافة النصوص التي سبق استخراجها ثم إضافة النصوص الجديدة 'الأرقام الناقصة تساوي قيمة الخلية الحالية 50009 في المثال مضافاً إليها قيمة الحلقة التكرارية والتي هنا تساوي 2 في بداية الحلقة التكرارية ليصبح الناتج 50011 ثم ناقص واحد لتحصل على أول رقم ناقص ألا وهو 5010 'يساوي 3 لتحصل في النهاية على الرقم التالي الناقص ألا وهو 5011[XX]مع الانتقال في الحلقة التكرارية يصبح المتغير                     Text = Text & Val(SH.Range("A" & I)) + XX - 1 & vbCrLf                 Next         End Select     Next 'رسالة لإظهار الأرقام الناقصة     MsgBox Text, vbMsgBoxRtlReading End Sub وإليكم الكود الثاني وهو أقوى في أنه لا يشترط ترتيب الأرقام
Sub MissingNumbers_YK_A() 'يقوم الكود باستخراج الأرقام الناقصة من سلسلة من الأرقام ولا يشترط ترتيب الأرقام '----------------------------------------------------------------------------     Dim InputRange As Range, OutputRange As Range, ValueFound As Range     Dim LowerVal As Single, UpperVal As Single, Count_I As Single, Count_J As Single     Dim NumRows As Long, NumColumns As Long     Dim Horizontal As Boolean          On Error GoTo ErrorHandler 'النطاق الذي يحتوي سلسلة الأرقام المراد استخراج الأرقام الناقصة منها     Set InputRange = Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row)     LowerVal = WorksheetFunction.Min(InputRange)     UpperVal = WorksheetFunction.Max(InputRange)     Horizontal = False 'بداية النطاق الذي سيتم استخراج النتائج به     Set OutputRange = Range("E2")          NumRows = OutputRange.Rows.Count     NumColumns = OutputRange.Columns.Count          Application.ScreenUpdating = False         If NumRows < NumColumns Then             Horizontal = True             NumRows = 1         Else             NumColumns = 1         End If                  Count_J = 1                  For Count_I = LowerVal To UpperVal             Set ValueFound = InputRange.Find(Count_I, LookIn:=xlValues, LookAt:=xlWhole)             If ValueFound Is Nothing Then                 If Horizontal Then                     OutputRange.Cells(NumRows, Count_J).Value = Count_I                     Count_J = Count_J + 1                 Else                     OutputRange.Cells(Count_J, NumColumns).Value = Count_I                     Count_J = Count_J + 1                 End If             End If         Next Count_I     Application.ScreenUpdating = True          Exit Sub      ErrorHandler: End Sub كما تمت إضافة حل بمعادلات الصفيف لتؤدي نفس الغرض
 
وإليكم أيضاً كود رائع للأخ الحبيب سليم حاصبيا مع شرح للأسطر ولا يشترط الترتيب للأرقام أيضاً
Sub MissingNumbers_SALIM() 'يقوم الكود باستخراج الأرقام الناقصة في سلسلة أرقام ولا يشترط الترتيب '------------------------------------------------------------------ 'تعريف المتغيرات     Dim Dico, D     Dim C As Range, Rng As Range     Dim B As Long, I As Long     Dim MinVal As Double, MaxVal As Double 'النطاق المراد استخراج الأرقام الناقصة منه     Set Rng = Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row) 'سطر لايجاد أقل قيمة رقمية في النطاق     MinVal = Application.WorksheetFunction.Min(Rng) 'سطر لايجاد أكبر قيمة رقمية في النطاق     MaxVal = Application.WorksheetFunction.Max(Rng) 'مسح محتويات النطاق الذي سيتم استخراج النتائج به     Range("G2", Range("G2").End(xlDown)).ClearContents 'إنشاء متغير من النوع كائن لتخزين الأرقام الناقصة به     Set Dico = CreateObject("Scripting.Dictionary") 'حلقة تكرارية لكل الأرقام المسلسلة     For I = 1 To (MaxVal - MinVal + 1) 'تعتمد هذه الأسطر على إضافة الرقم الناقص إلى الكائن المخصص لذلك         If Application.WorksheetFunction.CountIf(Rng, MinVal + I - 1) = Then         If Not Dico.Exists(MinVal + I - 1) Then Dico.Add (MinVal + I - 1), (MinVal + I - 1)         End If     Next I 'رقم صف البداية للنتائج في العمود السابع     B = 2 'حلقة تكرارية لوضع القيم التي تم تخزينها في النطاق المحدد     For Each D In Dico.items         Range("G" & B) = D         B = B + 1     Next D End Sub وعشان عيون أحبابي إليكم الكود الرابع وهو أفضل الأكواد من حيث أنه لا يشترط ترتيب الأرقام وأسطر الكود سهلة الفهم وسهلة التعامل معها
Sub MissingNumbers_YK_B() 'يقوم الكود باستخراج الأرقام الناقصة في تسلسل للأرقام ولا يشترط الترتيب '------------------------------------------------------------------- 'تعريف المتغيرات Dim InputRange As Range Dim X As Long, lRow As Long 'تعيين النطاق الذي سيحتوي على سلسلة الأرقام المراد استخراج الأرقام الناقصة منها Set InputRange = Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row) 'مسح محتويات النطاق الذي سيتم استخراج النتائج به Range("I2:I1000").ClearContents 'حلقة تكرارية من أقل قيمة بالنطاق لأكبر قيمة بالنطاق For X = WorksheetFunction.Min(InputRange) To WorksheetFunction.Max(InputRange) 'استخدام دالة البحث فإذا كانت القيمة المراد البحث عنها غير موجودة يعطي خطأ 'وبناءً على الخطأ يتم تنفيذ السطر التالي If IsError(Application.Match(X, InputRange, )) Then '[I] الرقم 2 هو رقم صف البداية في العمود '[I] يتم وضع الرقم الناقص في الخلية في الصف المحدد في العمود Cells(lRow + 2, "I") = X 'زيادة المتغير بمقدار واحد للانتقال لصف جديد لإدراج الأرقام الناقصة lRow = lRow + 1 End If Next X End Sub أترككم مع الملف المرفق ...للاستفادة بشكل عملي بالكود
كان معكم أخوكم ياسر خليل أبو البراء YK
(الموضوع مهدى للأخ الحبيب والأستاذ الكبير أسامة البراوي OB ومهدى للأخ الفاضل نايف - م)
حمل الملف من هنا
 
تقبلوا تحياتي

السلام عليكم نبدأ بها 
جرب الكود التالي
Sub Test() Dim ws As Worksheet, sh As Worksheet, sTarget As String, lr As Long, m As Long, iRow As Long Application.ScreenUpdating = False Set ws = ThisWorkbook.Worksheets("اذن") lr = ws.Cells(Rows.Count, 1).End(xlUp).Row If lr < 6 Then MsgBox "No Data", vbExclamation: Exit Sub Select Case ws.Range("C2").Value Case "اذن صرف": sTarget = "صرف" Case "اذن اضافه": sTarget = "اضافه" Case Else: MsgBox "No Such Worksheet", vbExclamation: Exit Sub End Select Set sh = ThisWorkbook.Worksheets(sTarget) m = sh.Cells(Rows.Count, "B").End(xlUp).Row + 1 For iRow = 6 To lr sh.Range("A" & m).Resize(, 6).Value = Array(sh.Range("A" & m).Row - 2, ws.Range("E2").Value, ws.Range("C4").Value, ws.Range("C3").Value, ws.Cells(iRow, 1).Value, ws.Cells(iRow, 2).Value) sh.Range("I" & m).Value = ws.Cells(iRow, 4).Value If sh.Name = "اضافه" Then sh.Range("J" & m).Value = ws.Cells(iRow, 5).Value End If m = m + 1 Next iRow Application.ScreenUpdating = True MsgBox "Done", 64 End Sub  

وعليكم السلام أخي الكريم
أدرج موديول جديد وضع الدالة المعرفة التالية في الموديول
Function xDupsV(fCol As Range, Optional offsetCol As Integer = -1) Dim a, r1 As Range, r2 As Range, c As Range, cc As Range, i As Long, j As Long Application.Volatile True Set r1 = fCol Set r2 = r1.Offset(, offsetCol) ReDim a(1 To 1) For Each c In r1 Set cc = c.Offset(, offsetCol) If Not IsEmpty(c) And cc > 0 Then For j = 1 To cc i = i + 1 ReDim Preserve a(1 To i) a(i) = c Next j End If Next c xDupsV = WorksheetFunction.Transpose(a) End Function ثم في الخلية C11 ضع المعادلة بهذا الشكل
=xdupsv(F3:F6) لا تنسى أن تقوم بمسح النطاق C11 إلى آخر النطاق قبل وضع المعادلة

وعليكم السلام
جرب الكود التالي
Private Sub UserForm_Initialize() Dim fso As Object, oFolder As Object, sPath As String, i As Long sPath = "D:\" Set fso = CreateObject("Scripting.FileSystemObject") UserForm1.ListBox1.Clear If fso.FolderExists(sPath) Then Set oFolder = fso.GetFolder(sPath) For Each oFolder In oFolder.SubFolders If Left(oFolder.Name, 1) <> "$" Then i = i + 1 UserForm1.ListBox1.AddItem oFolder.Name End If Next oFolder End If Set fso = Nothing End Sub  

غير الجزء التالي
If Weekday(Cells(4, i)) > 5 ليصبح
If Weekday(Cells(4, i)) = 6  

وعليكم السلام أخي الكريم
قم بتغيير اسم الملف المسمى بيانات العاملين 21-9-2023 إلى Employees DB أو قم بتغيير الاسم في الكود (كما يحلو لك)
ضع الكود التالي في الملف المسمى الإدارة العامة
Sub Test() Dim a, wb As Workbook, ws As Worksheet, sh As Worksheet, c As Range, dic As Object, sName As String, lr As Long Application.ScreenUpdating = False Set dic = CreateObject("Scripting.Dictionary") Set wb = Workbooks.Open(ThisWorkbook.Path & "\Employees DB.xls") Set ws = wb.Worksheets(1) Set sh = ThisWorkbook.ActiveSheet For Each c In ws.Range("C6:C" & ws.Cells(Rows.Count, "C").End(xlUp).Row) sName = c.Value If Not dic.Exists(sName) And sName <> Empty Then dic.Add sName, Array(c.Offset(0, 1).Value, c.Offset(0, 2).Value, c.Offset(0, 3).Value) End If Next c wb.Close SaveChanges:=False lr = sh.Cells(Rows.Count, "B").End(xlUp).Row sh.Range("E3:G" & lr).ClearContents For Each c In sh.Range("B3:B" & lr) sName = c.Value If dic.Exists(sName) Then a = dic(sName) c.Offset(, 3).Resize(, 3).Value = a End If Next c Application.ScreenUpdating = True End Sub  

جرب الكود التالي عله يفي بالغرض بإذن الله
Sub Test() Dim x, ws As Worksheet, lr As Long, i As Long, j As Long, startSeq As Long, endSeq As Long Application.ScreenUpdating = False Set ws = ThisWorkbook.Worksheets(1) lr = ws.Cells(ws.Rows.Count, "L").End(xlUp).Row ws.Range("A2:A" & lr).ClearContents For i = 2 To lr j = 0 x = Application.Match(ws.Cells(i, "L").Value, ws.Columns("T"), 0) If Not IsError(x) Then startSeq = ws.Cells(x, "U").Value endSeq = ws.Cells(x, "V").Value Do j = j + 1 ws.Cells(i + j - 1, "A").Value = startSeq If startSeq > endSeq Then ws.Cells(i + j - 1, "A").Value = Empty startSeq = startSeq + 1 Loop Until ws.Cells(i, "L").Value <> ws.Cells(i + j, "L").Value i = i + j - 1 End If Next i Application.ScreenUpdating = True End Sub إذا قمت بحذف صفوف من البيانات سيلزمك تنفيذ الكود من جديد لضبط التسلسل

وعليكم السلام أخي الكريم ياسر
جرب الكود التالي عله يفي بالغرض بإذن الله
تم الاعتماد على العمود R في الورقة الثانية لتسجيل اسم Check Box الذي تم ترحيله تفادياً لترحيله مرة أخرى .. يمكنك إخفاء العمود أو إخفاء القيم في العمود R
Sub Test() Dim x, ws As Worksheet, sh As Worksheet, chkBox As CheckBox, r As Long, m As Long, cnt As Long Application.ScreenUpdating = False Set ws = ThisWorkbook.Sheets(1) Set sh = ThisWorkbook.Sheets(2) For r = 3 To ws.Cells(ws.Rows.Count, "C").End(xlUp).Row Set chkBox = ws.Shapes("Check Box " & r - 2).OLEFormat.Object x = Application.Match(chkBox.Name, sh.Columns("R"), 0) If IsError(x) Then If chkBox.Value = 1 Then m = sh.Cells(Rows.Count, 1).End(xlUp).Row + 1 sh.Range("A" & m).Resize(, 17).Value = ws.Range("A" & r).Resize(, 17).Value sh.Range("R" & m).Value = chkBox.Name cnt = cnt + 1 End If End If Next r Application.ScreenUpdating = True If cnt > 0 Then MsgBox "Total = " & cnt, 64 Else MsgBox "Nothing Transferred", vbExclamation End Sub  

السلام عليكم أخي الكريم
جرب الكود التالي في حدث المصنف ThisWorkbook
Private Sub Workbook_NewSheet(ByVal Sh As Object) Dim R As Integer, G As Integer, B As Integer Randomize R = Int(Rnd() * 256) G = Int(Rnd() * 256) B = Int(Rnd() * 256) Sh.Tab.Color = RGB(R, G, B) End Sub سيعمل الكود فقط عند إضافة ورقة عمل جديدة

أخي الكريم
ضع الكود التالي في موديول عادي
من هنا
Sub Test() Dim myFile As String Dim lRow As Long Sheets("Sheet1").Range("A5:E25").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Sheets("Sheet1").Range("C1:C2"), CopyToRange:=Sheets("Sheet2").Range("A6:E6"), Unique:=False myFile = "D:\Print\" & Sheets(2).Range("G4").Text & "-" & Sheets(1).Range("L3").Text & ".pdf" lRow = Sheets(2).Range("A" & Rows.Count).End(xlUp).Row + 1 Sheets(2).ExportAsFixedFormat Type:=xlTypePDF, Filename:=myFile MsgBox "Done...", 64 End Sub ثم ضع الكود التالي في حدث الفورم
Private Sub CommandButton1_Click() Test End Sub تقبل تحياتي
 

مرحباً بك بين إخوانك في منتدى أوفيسنا

أنشئ ملف نصي بالمفكرة وقم بحفظه واجعل Encoding إلى Unicode

ثم من التبويب Data اختر الأمر From Text ( أوفيس 2007 )
ثم اتبع التعليمات Next حتى Finish

عاشق الإكسيل

أخي الكريم
إليك الحل في الملف المرفق
دمت على طاعة الله
أرجو منك الدعاء بظهر الغيب

عاشق الإكسيل
Time_Function.rar

الأخ الحبيب العمري
الأخوة تعبوا معاك
ياريت ترفق ملف بعد كدا لو حبيت تطرح مشكلة حتى تتضح المشكلة تماماً للأخوة الأعضاء
عموماً ..إليك الملف التالي فيه شرح لكيفية نسخ ولصق البيانات على نطاق تمت فلترته...
لو كانت البيانات ثابته كما في شرحك فالموضوع سهل كل ما عليك أن تحدد النطاق المفلتر ثم f5 ثم special ثم Visible cells only ثم تقوم بتحرير الخلية الأولى ثم أخيراً Ctrl+Enter
أما إذا كانت البيانات المراد لصقها متغيرة فهذا مبين بالشرح
أخوك أبو البراء
PasteOverFilteredRange.rar

وهذه معادلة أخرى أخف من الأولى


=SUMPRODUCT((SUM($A$1:$A$4)*($B$1:$B$4)))

لا تنسانا من صالح الدعاء
أخوك أبو البراء

أخي الكريم
لم تجب على سؤالي ، ولم توضح التفاصيل ، لأن التفاصيل دائما مهمة ....
 
عموما تفضل المرفق
أضفت عمود لكل مادة بحيث تعرف المادة التي تم التغيير فيها
Target VBA.rar

أخي الكريم خالد جرب الكود التالي عله يفي بالغرض (طبعاً يوضع الكود في المصنف المسمى PickList) ويحفظ بامتداد xlsm ... قم بفتح الملف الأول والملف الجديد الذي قمت بحفظه بامتداد xlsm ونفذ الكود وستظهر النتائج في العمود الثاني في الملف الجديد المسمى PickList.xlsm
Sub Test() Dim swb As Workbook Dim twb As Workbook Dim arr1 As Variant Dim arr2 As Variant Dim v As Variant Dim d As Object Dim m As Long Dim n As Long Dim r0 As Long Dim r As Long Dim s As Long Dim c As Long Set swb = Workbooks("SerializePlantStockReport.xlsx") Set twb = ThisWorkbook Set d = CreateObject("Scripting.Dictionary") m = swb.Sheets(1).Range("A" & Rows.Count).End(xlUp).Row arr1 = swb.Sheets(1).Range("C2:E" & m).Value n = twb.Sheets(1).Range("A" & Rows.Count).End(xlUp).Row arr2 = twb.Sheets(1).Range("A2:B" & n).Value For s = 1 To n - 1 v = arr2(s, 1) If d.exists(v) Then r0 = d(v) Else r0 = 0 End If For r = r0 + 1 To m If arr1(r, 1) = v Then arr2(s, 2) = CStr(arr1(r, 3)) d(v) = r Exit For End If Next r Next s twb.Sheets(1).Range("A2:B" & n).Value = arr2 End Sub  

تفضل أخي الفاضل أبو نبأ الملف التالي ..جرب الملف ووافنا بالنتائج
 
Client Account Report YasserKhalil V3.rar

روح لمحرر الأكواد ومن Tools اختر References وشوف المكتبات اللي بجوارها كلمة Missing وشيل علامة الصح

جرب المعادلة
=SUMIF('2'!A4:A7,C3,INDIRECT("'" & E2))  

أخي الكريم إليك الكود فيه حل للمشكلة
Sub Store_ActiveCell_In_Variable_Go_Back_At_The_End() Dim c As Range Set c = ActiveCell 'Your Macro Application.Goto Range("K35") Application.Wait Now + TimeValue("00:00:03") Application.Goto c End Sub  

وعليكم السلام أخي الكريم زياد
جرب الكود التالي في حدث ورقة العمل المراد التجميع فيها
قم بكتابة القسم في العمود الثاني ..
Private Sub Worksheet_Change(ByVal Target As Range) Dim ws As Worksheet Dim xf As Variant If Target.Cells.Count > 1 Then Exit Sub If Target.Row > 3 And Target.Column = 2 Then Application.EnableEvents = False If Target = "" Then Target.Offset(, -1).ClearContents: Target.Offset(, 1).Resize(, 6).ClearContents: GoTo Skipper For Each ws In ThisWorkbook.Worksheets(Array("وحدة الانتاج", "وحدة النقل", "وحدة التوزيع")) xf = Application.Match(Target, ws.Columns(2), 0) If IsNumeric(xf) Then Target.Offset(, -1) = Target.Row - 3 Target.Offset(, ws.Index * 2 - 1) = ws.Cells(xf, 3) Target.Offset(, ws.Index * 2) = ws.Cells(xf, 4) End If Next ws Skipper: Application.EnableEvents = True End If End Sub  

جرب الكود التالي 
Private Sub Worksheet_Change(ByVal Target As Range) If Target.Row > 7 And Target.Column = 5 Then Application.EnableEvents = False On Error GoTo Skipper If Target.Value = "" Then Target.Offset(, 1) = "" Target.Offset(, 1) = Application.WorksheetFunction.VLookup(Target, Range("I8:J20"), 2, False) Skipper: Application.EnableEvents = True End If End Sub  

Private Sub UserForm_Activate() Dim i As Long For i = 17 To 32 Me.Controls("Label" & i) = Range("C" & i - 14) Next i For i = 37 To 42 Me.Controls("Label" & i) = Range("D" & i - 34) Next i End Sub  

أخي الكريم ..
إليك الكود التالي .. لا حاجة للاحتفاظ بالمعادلات في ورقة الهدف (النتائج) .. حيث وضعت لك دوال معرفة تقوم بنفس المهمة .. وتوفر عليك عناء كتابة وضبط المعادلات ..
أدرج موديول جديد .. ثم ضع الكود التالي وجرب الكود وأخبرنا بالنتائج
Option Explicit Sub TransferDataUsingArrays() Const startDate As Date = #10/1/2017# Dim ws As Worksheet Dim sh As Worksheet Dim arr As Variant Dim temp As Variant Dim birthDate As Date Dim i As Long Dim j As Long Dim p As Long Set ws = Sheets("بيانات الطلاب") Set sh = Sheets("سجل 41 مستجدين") arr = ws.Range("B17:T" & ws.Range("C" & Rows.Count).End(xlUp).Row).Value ReDim temp(1 To UBound(arr, 1), 1 To 18) For i = 1 To UBound(arr, 1) If arr(i, 5) = "مستجد" Or arr(i, 5) = "مستجدة" Then p = p + 1 For j = 1 To 18 temp(p, j) = arr(i, Choose(j, 1, 2, 7, 8, 9, 10, 7, 8, 9, 13, 4, 14, 15, 16, 2, 11, 12, 17)) Next j temp(p, 1) = p On Error Resume Next birthDate = CDate(temp(p, 3) & "/" & temp(p, 4) & "/" & temp(p, 5)) temp(p, 7) = CalculateAge(birthDate, startDate, "d") temp(p, 8) = CalculateAge(birthDate, startDate, "m") temp(p, 9) = CalculateAge(birthDate, startDate, "y") On Error GoTo 0 temp(p, 15) = KhFatherName(CStr(temp(p, 2))) End If Next i If p > 0 Then With sh.Range("B8") .Resize(1000, UBound(temp, 2)).ClearContents .Resize(p, UBound(temp, 2)).Value = temp End With End If End Sub Function KhFatherName(ByVal Name As String) As String Dim khString As String Dim searchChar As String Dim khMid As String Dim khRep As String Dim khMyNo As Integer On Error GoTo Err_KhFatherName If IsEmpty(Name) Then GoTo Err_KhFatherName khString = KhFatherReplace(Trim(Name)) & " " searchChar = " " khMyNo = InStr(1, khString, searchChar, 1) khMid = Trim(Mid(khString, khMyNo, Len(khString))) khRep = Replace(khMid, "_", " ") KhFatherName = khRep Exit Function Err_KhFatherName: KhFatherName = "" End Function Private Function KhFatherReplace(ByVal Kh_Sub As String) As String Dim myArray As Variant Dim ar As Variant Dim sn As String Dim re As String myArray = Array("عبد ", "أبو ", "ابو ", "آل ", " الله", " الدين", " الإسلام", " الاسلام", " الحق", " النصر", " العهد", " النور", " بالله", " الزهراء") sn = Kh_Sub For Each ar In myArray re = Replace(ar, " ", "_") sn = Replace(sn, ar, re) Next ar KhFatherReplace = sn End Function Function CalculateAge(birth As Variant, start As Variant, str As String) Dim y As Long Dim m As Long Dim d As Long If Not IsDate(birth) Or Not IsDate(start) Then GoTo Skipper m = DateDiff("m", birth, start) d = DateDiff("d", DateAdd("m", m, birth), start) If d < 0 Then m = m - 1 d = DateDiff("d", DateAdd("m", m, birth), start) End If y = m \ 12 m = m Mod 12 Select Case str Case "d" CalculateAge = d Case "m" CalculateAge = m Case "y" CalculateAge = y End Select Exit Function Skipper: CalculateAge = "" End Function  

وعليكم السلام أخي محمد
جرب الكود التالي
Private Sub UserForm_Initialize() Label2 = Application.WorksheetFunction.COUNTA(Range("B2:B200")) End Sub