ابراهيم الحداد

السلام عليكم ورحمة الله استخدم هذه المعادلة =IF($J$3="";"";SUMIF('كشف حساب العملاء'!$C$4:$C$344;$J$3;'كشف حساب العملاء'!$E$4:$E$344)-SUMIF('كشف حساب العملاء'!$C$4:$C$344; $J$3;'كشف حساب العملاء'!G4:G344))

السلام عليكم ورحمة الله اليك الملف بعد اضافة بعض البيانات لعام 2022 للتجربة Sub GteData() Dim ws As Worksheet, Sh As Worksheet Dim Arr(), Temp() Dim y As Integer, m As Integer Dim yy As Integer, mm As Integer Dim i As Long, j As Long, p As Long Set ws = Sheets("تقرير السنين") Set Sh = Sheets("محمود") ws.Range("A9:E" & ws.Range("B" & Rows.Count).End(3).Row).ClearContents m = Month("01/" & ws.Range("A3").Value) y = ws.Range("B3").Value Arr = Sh.Range("A9:E" & Sh.Range("B" & Rows.Count).End(3).Row).Value ReDim Temp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2)) For i = 1 To UBound(Arr, 1) yy = Year(Arr(i, 2)) mm = Month(Arr(i, 2)) If yy = y And mm = m Then p = p + 1 For j = 1 To UBound(Arr, 2) Temp(p, j) = Arr(i, j) Next End If Next If p > 0 Then ws.Range("A9").Resize(p, UBound(Temp, 2)).Value = Temp End Sub Naser.xlsm

السلام عليكم ورحمة الله اخى الكريم قم فقط بتغيير ارقام الشيتات فى الكود لتتناسب مع رقم الشيت الموجود بها الشيكبوكس مثلا Sheet1.Shapes("Check Box 1") تصبح Sheet2.Shapes("Check Box 1") وهكذا

السلام عليكم ورحمة الله الكود الاول لاظهار واخفاء الخطين و يربط بالشيكبوكس الاول Sub AddStright() If Sheet1.Shapes("Check Box 3").OLEFormat.Object.Value = 1 Then Sheet1.Shapes("Straight Connector 3").Visible = msoTrue Sheet1.Shapes("Straight Connector 2").Visible = msoTrue Else Sheet1.Shapes("Straight Connector 3").Visible = msoFalse Sheet1.Shapes("Straight Connector 2").Visible = msoFalse End If End Sub الكود الثانى للاثنين الباقيين و يربط بهما الواحد تلو الاخر Sub AddWords() Dim Frst As String, ForB As String Frst = " للمستفيد الأول" ForB = "يصرف لحامله" If Sheet1.Shapes("Check Box 1").OLEFormat.Object.Value = 1 Then Sheet1.Shapes("TextBox 7").TextEffect.Text = Frst ElseIf Sheet1.Shapes("Check Box 2").OLEFormat.Object.Value = 1 Then Sheet1.Shapes("TextBox 7").TextEffect.Text = ForB Else Sheet1.Shapes("TextBox 7").TextEffect.Text = "" End If End Sub

السلام عليكم ورحمة الله استخدم المعادلة التالية =LOOKUP(2;1/($B2:$E2<>"");$B2:$E2) او المعادلة التالية =INDEX($A$2:$E$5;MATCH(J3;$A$2:$A$5;0);LARGE(IF($B2:$E2<>"";COLUMN($B2:$E2));1))

السلام عليكم ورحمة الله اخى الكريم لقد فهمت من المشاركة الاولى انك تريد اضافة ورقة لكل موظف ومن ثم اضافة البيانات التى تخصه فقط فى تلك الورقة ان كان فهمى هذا صحيحا فيمكنك استخدام الكودين الاتيين الاول لاضافة ورقة جديدة لاى موظف جديد و الثانى لترحيل البيانات الخاصة به الى ورقته اليك الكود الاول يربط الزر الخاص بتنفيذ الكود بالكود الثانى Sub CreateAcc() Dim ws As Worksheet, Sh As Worksheet Dim LR As Long, Rng As Range, C As Range Set ws = Sheets("Salary04 (2)") LR = ws.Range("F" & Rows.Count).End(3).Row Set Rng = ws.Range("F3:F" & LR) On Error Resume Next For Each C In Rng If Len(Trim(C.Value)) > 0 Then If Len(Worksheets(C.Value).Name) = 0 Then Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = C.Value End If End If With Sheets(C.Value) .Range("A2:H2") = Array("التسلسل", "رقم المركز", "رقم الموظف", _ "الشهر", "السنة", "اسم الموظف", "البند", "المبلغ") .Range("A2:H2").Font.Size = 14 .Range("A2:H2").Font.Bold = True .Range("A2:H2").Columns.AutoFit End With Next End Sub الكود الثانى ويتم ربطه بالزر Sub TrData() Dim i As Long, wd As Worksheet Dim C As Range, Sh As Worksheet Set wd = Sheets("Salary04 (2)") CreateAcc For Each C In wd.Range("F3:F" & wd.Range("F" & Rows.Count).End(3).Row) x = C.Row i = 7 Do While i <= 100 If wd.Cells(x, i) <> "" Then p = p + 1 With Sheets(C.Value) .Cells(p + 2, 1) = wd.Cells(x, 1) .Cells(p + 2, 2) = wd.Cells(x, 2) .Cells(p + 2, 3) = wd.Cells(x, 3) .Cells(p + 2, 4) = wd.Cells(x, 4) .Cells(p + 2, 5) = wd.Cells(x, 5) .Cells(p + 2, 6) = wd.Cells(x, 6) .Cells(p + 2, 7) = wd.Cells(2, i) .Cells(p + 2, 8) = wd.Cells(x, i) .Range("A2:H" & p + 2).Columns.AutoFit .Range("A2:H" & p + 2).Font.Bold = True .Range("A2:H" & p + 2).Font.Size = 14 .Range("A2:H" & p + 2).Borders.LineStyle = 1 End With End If i = i + 1 Loop p = 0 Next End Sub

السلام عليكم ورحمة الله تفضل SpllingWord.xlsb

السلام عليكم ورحمة الله جرب هذه الدالة المخصصة Function SepLetrs(Cel As Range) As String Dim Arr, Tmp, Word, Strg Dim i As Long, j As Long Arr = Array("ا", "ب", "ت", "ث", "ج", "ح", "خ", "د", "ذ", "ر", "ز", "س", "ش", "ص", _ "ض", "ع", "غ", "ط", "ظ", "ف", "ق", "ك", "ل", "م", "ن", "ه", "و", "ي", "ى", "ة") Tmp = Array("الف", "باء", "تاء", "ثاء", "جيم", "حاء", "خاء", "دال", "ذال", _ "راء", "زين", "سين", "شين", "صاد", "ضاد", "عين", "غين", "طاء", "ظاء", _ "فاء", "قاف", "كاف", "لام", "ميم", "نون", "هاء", "واو", "ياء", "ياء", "تاء مربوطة") For i = 1 To Len(Cel) Word = Mid(Cel, i, 1) For j = LBound(Arr) To UBound(Arr) If Word = Arr(j) Then Strg = Strg & " " & Replace(Word, Arr(j), Tmp(j)) End If Next Next SepLetrs = Strg End Function

السلام عليكم ورحمة الله استخدم الكود التالى و لكن يجب عليك الغاء الهايبرلنك الذى يربط الزر بورقة حساب حتى يعمل معك الكود Sub fildata() Dim lr As Long lr = Sheets("شهر3").Range("A" & Rows.Count).End(3).Row Sheets("حساب").Activate Sheets("حساب").Range("A3").Value = Sheets("شهر3").Range("A" & lr).Value End Sub

السلام عليكم ورحمة الله اذا كنت لا تريد عمل زر لتنفيذ الكود يمكنك وضع هذا الكود فى حدث الورقة "كشف حساب" Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = "$H$6" Then Call GetData End Sub

السلام عليكم ورحمة الله استخدم هذا الكود Sub GetData() Dim ws As Worksheet, Sh As Worksheet Dim ShNam As String, Arr As Variant, XSum As Double Dim i As Long, j As Long Set ws = Sheets("كشف حساب") ws.Range("B9:L14").ClearContents ShNam = ws.Range("H6").Text Set Sh = Sheets(ShNam) XSum = Sh.Range("K6").Value Arr = Sh.Range("B11:L" & Sh.Range("K" & Rows.Count).End(xlUp).Row).Value ws.Range("B9").Resize(UBound(Arr, 1), UBound(Arr, 2)).Value = Arr ws.Range("D16") = XSum End Sub

السلام عليكم ورحمة الله اجعل المعادلة هكذا =INDEX(B2:AA5;MATCH(E13;A2:A5;0);MATCH(D13;B1:AA1;0))

السلام عليكم ورحمة الله فى كود التفقيط استبدل هذه الفقرة Else .Value = "فقط " & Texte1 & St2 بتلك الفقرة Else .Value = "فقط " & Texte1 & Stx1 & St2 و تنتهى المشكلة باذن الله

السلام عليكم ورحمة الله الحاقا بالمشاركة السابقة ( بعد ان وقع سهوا) فى كود دالة التفقيط استبدل هذه الفقرة MyNumber = Abs(Number_Value) MyNumber = Int(MyNumber) بتلك الفقرة If Number_Value = Empty Then Number_Value = 0 Else MyNumber = Abs(Number_Value) End If MyNumber = Int(MyNumber) حتى يعمل معك الكود بشكل سليم .... فيصبح الكود كاملاً Public Function Ar_WriteDownNumber(Number_Value As String, Optional Main_Currency As String, Optional Small_Currency As String, Optional Main_To_Small_Factor As Integer) Dim MyNumber Dim MyFractions Dim WordFraction Dim Pr Dim Hu Dim Th Dim PrTh Dim HuTh Dim PrMi Dim HuMi Dim Hu1 Dim Pr2 Dim l Dim Thu_Text As String Dim Mil_Text As String If Val(Main_To_Small_Factor) = 0 Then Main_To_Small_Factor = 100 If Small_Currency = "" Then If Main_To_Small_Factor = 100 Then Small_Currency = " جزء من مائة" Else Small_Currency = " جزء من ألف" End If End If If Number_Value = Empty Then Number_Value = 0 Else MyNumber = Abs(Number_Value) End If MyNumber = Int(MyNumber) If InStr(Number_Value, ".") > 0 Then MyFractions = Mid(Number_Value, InStr(Number_Value, ".") + 1, 3) End If l = Len(MyNumber) Pr = Right(MyNumber, 2) Ar_WriteDownNumber = MyPrimary(Pr) If l > 2 Then Hu = Right(Left(MyNumber, l - 2), 1) If Val(Hu) <> 0 Then If Ar_WriteDownNumber <> 0 Then Ar_WriteDownNumber = MyHundreds(Hu) & " و " & Ar_WriteDownNumber Else Ar_WriteDownNumber = MyHundreds(Hu) End If End If Else GoTo 1 End If If l > 3 Then Th = Right(Left(MyNumber, l - 3), 2) If Val(Th) <> 0 Then Thu_Text = "" If Ar_WriteDownNumber <> 0 Then Ar_WriteDownNumber = MyThousand(Th) & " و " & Ar_WriteDownNumber Else Ar_WriteDownNumber = MyThousand(Th) End If Else Thu_Text = " ألف" End If Else GoTo 1 End If If l > 5 Then HuTh = Right(Left(MyNumber, l - 5), 1) If Val(HuTh) <> 0 Then If Ar_WriteDownNumber <> 0 Then Ar_WriteDownNumber = MyHundreds(HuTh) & Thu_Text & " و " & Ar_WriteDownNumber Else Ar_WriteDownNumber = MyHundreds(HuTh) & Thu_Text End If End If Else GoTo 1 End If If l > 6 Then PrTh = Right(Left(MyNumber, l - 6), 2) If Val(PrTh) <> 0 Then Mil_Text = "" If Ar_WriteDownNumber <> 0 Then Ar_WriteDownNumber = MillionPrimary(PrTh) & " و " & Ar_WriteDownNumber Else Ar_WriteDownNumber = MillionPrimary(PrTh) & Mil_Text End If Else Mil_Text = " مليون" End If Else GoTo 1 End If If l > 8 Then HuMi = Right(Left(MyNumber, l - 8), 1) If Ar_WriteDownNumber <> 0 Then Ar_WriteDownNumber = MyHundreds(HuMi) & Mil_Text & " و " & Ar_WriteDownNumber Else Ar_WriteDownNumber = MyHundreds(HuMi) & Mil_Text End If End If If l > 9 Then Ar_WriteDownNumber = MyNumber 1: If Len(Trim(Ar_WriteDownNumber)) > 0 Then Ar_WriteDownNumber = Ar_WriteDownNumber & " " & Main_Currency Else Ar_WriteDownNumber = "" End If If Len(MyFractions) < 2 Then MyFractions = MyFractions + "0" If Len(MyFractions) < 3 Then MyFractions = MyFractions + "0" If Val(MyFractions) = 0 Then Exit Function If Main_To_Small_Factor = 100 Then Pr2 = Left(MyFractions, 2) Else Pr2 = Mid(MyFractions, 2, 2) End If WordFraction = MyPrimary(Pr2) If Main_To_Small_Factor > 100 Then Hu1 = Left(MyFractions, 1) If Val(Hu1) <> 0 Then If WordFraction <> 0 Then WordFraction = MyHundreds(Hu1) & " و " & WordFraction Else WordFraction = MyHundreds(Hu1) End If End If Else GoTo 2 End If 2 If Main_Currency <> "" Then If Len(Trim(Ar_WriteDownNumber)) > 0 Then Ar_WriteDownNumber = Ar_WriteDownNumber & " و " & WordFraction & " " & Small_Currency Else Ar_WriteDownNumber = WordFraction & " " & Small_Currency End If Else If Len(Trim(Ar_WriteDownNumber)) > 0 Then If Main_To_Small_Factor = 100 Then Small_Currency = " جزء من مائة" Else Small_Currency = " جزء من ألف" End If Ar_WriteDownNumber = Ar_WriteDownNumber & " فاصل " & WordFraction Else Ar_WriteDownNumber = WordFraction & " " & Small_Currency End If End If End Function Private Function MyPrimary(J) Dim myText1 Dim myText2 Dim K K = Right(J, 1) J = Val(J) If J < 20 Then MyPrimary = Choose(J, "واحد", "اثنان", "ثلاثة", "أربعة", "خمسة", "ستة", "سبعة", "ثمانية", "تسعة", "عشرة", "إحدى عشر", "اثنا عشر", "ثلاثة عشر", "أربعة عشر", "خمسة عشر", "ستة عشر", "سبعة عشر", "ثمانية عشر", "تسعة عشر") Else myText1 = Choose(Val(K), "واحد", "اثنان", "ثلاثة", "أربعة", "خمسة", "ستة", "سبعة", "ثمانية", "تسعة") myText2 = Choose(Int((J - K) / 10) - 1, "عشرون", "ثلاثون", "أربعون", "خمسون", "ستون", "سبعون", "ثمانون", "تسعون") If Not IsNull(myText1) Then MyPrimary = myText1 & " و " & myText2 Else MyPrimary = myText2 End If End If End Function Private Function MyHundreds(J) J = Val(J) MyHundreds = Choose(J, "مائة", "مائتان", "ثلاثمائة", "أربعمائة", "خمسمائة", "ستمائة", "سبعمائة", "ثمانمائة", "تسعمائة") End Function Private Function MyThousand(J) Dim myText1 Dim myText2 Dim K K = Right(J, 1) J = Val(J) If J < 20 Then MyThousand = Choose(J, "ألف", "ألفان", "ثلاثة آلاف", "أربعة آلاف", "خمسة آلاف", "ستة آلاف", "سبعة آلاف", "ثمانية آلاف", "تسعة آلاف", "عشرة آلاف", "إحدى عشر ألفاً", "اثنا عشر ألفاً", "ثلاثة عشر ألفاً", "أربعة عشر ألفاً", "خمسة عشر ألفاً", "ستة عشر ألفاً", "سبعة عشر ألفاً", "ثمانية عشر ألفاً", "تسعة عشر ألفاً") Else myText1 = Choose(K, "واحد", "اثنان", "ثلاثة", "أربعة", "خمسة", "ستة", "سبعة", "ثمانية", "تسعة") myText2 = Choose((J - K) / 10 - 1, "عشرون", "ثلاثون", "أربعون", "خمسون", "ستون", "سبعون", "ثمانون", "تسعون") If Not IsNull(myText1) Then MyThousand = myText1 & " و" & myText2 & " الف" Else MyThousand = myText2 & " الف" End If End If End Function Private Function MillionPrimary(J) Dim myText1 Dim myText2 Dim K K = Right(J, 1) J = Val(J) If J < 20 Then MillionPrimary = Choose(J, "مليون", "مليونان", "ثلاثة ملايين", "أربعة ملايين", "خمسة ملايين", "ستة ملايين", "سبعة ملايين", "ثمانية ملايين", "تسعة ملايين", "عشرة ملايين", "إحدى عشر مليوناً", "اثنا عشر مليوناً", "ثلاثة عشر مليوناً", "أربعة عشر مليوناً", "خمسة عشر مليوناً", "ستة عشر مليوناً", "سبعة عشر مليوناً", "ثمانية عشر مليوناً", "تسعة عشر مليوناً") Else myText1 = Choose(Val(K), "واحد", "أثنان", "ثلاثة", "أربعة", "خمسة", "ستة", "سبعة", "ثمانية", "تسعة") myText2 = Choose(Int((J - K) / 10) - 1, "عشرون مليون", "ثلاثون مليون", "أربعون مليون", "خمسون مليون", "ستون مليون", "سبعون مليون", "ثمانون مليون", "تسعون مليون") If Not IsNull(myText1) Then MillionPrimary = myText1 & " و " & myText2 Else MillionPrimary = myText2 End If End If End Function التفقيط المعدل2.xlsm

السلام عليكم ورحمة الله اجعل الكود هكذا Sub TEST() Dim Sh As Worksheet, LR As Long, Cel As Range Dim Stx1 As String, Stx2 As String, St1 As String, St2 As String, Texte1 As String, Texte2 As String For Each Sh In Worksheets(Array("DATA")) LR = Sh.Cells(Sh.Rows.Count, 17).End(xlUp).Row Stx1 = "جنيها ": Stx2 = "قرشا ": St1 = "و ": St2 = "لا غير" 'كيف يمكن تعديل هذين السطرين لتفقيط خانتى القرش والجنيه الملونه باللون الاصفر Texte1 = Ar_WriteDownNumber(Cells(LR, "Q")) Texte2 = Ar_WriteDownNumber(Cells(LR, "P")) With Sh.Cells(LR + 2, "C") ''' هنا حدد اين تريد يظهرالتفقيط 'وهذا السطر If Len(Texte2) > 0 Then .Value = "فقط " & Texte1 & Stx1 & St1 & Texte2 & Stx2 & St2 Else .Value = "فقط " & Texte1 & St2 End If End With ActiveWindow.SelectedSheets.PrintOut Copies:=1 ' Sh.Range(Sh.Cells(LR + 1, "A"), Sh.Cells(LR + 12, "C")).ClearContents Next Sh End Sub

السلام عليكم ورحمة الله اخى الكريم ضع المعادلة التالية فى الخلية "B5" ثم اضغط Ctrl+Shift+enter ثم اسحب نزولا =IFERROR(INDEX(ورقة1!$A$2:$C$152;SMALL(IF(ورقة1!$A$2:$A$152=$F$2;ROW(ورقة1!$A$2:$C$152));ROW(A1))-1;3);"") اما المعادلة التالية فضعها فى الخلية "C5" و كرر ما سبق =IFERROR(INDEX(ورقة1!$A$2:$C$152;SMALL(IF(ورقة1!$A$2:$A$152=$F$2;ROW(ورقة1!$A$2:$C$152));ROW(A1))-1;2);"")

السلام عليكم ورحمة الله استخدم هذه المعادلة =IFNA(VLOOKUP($A2;التحميل!$A$2:$B$1000;2;0);VLOOKUP($A2;مستودع!$A$2:$B$1000;2;0))

السلام عليكم ورحمة الله ضع الكود الاول فى موديول مستقل Sub GetUniqueValues() Dim Rng As Range, Rng1 As Range Set Rng = Sheet2.Range("C5:C" & Sheet2.Range("C" & Rows.Count).End(3).Row + 1) Set Rng1 = Sheet2.Range("E5:E" & Sheet2.Range("E" & Rows.Count).End(3).Row + 1) Sheet1.Range("B2:B" & Sheet1.Range("B" & Rows.Count).End(3).Row).Name = "MyRange" Sheet1.Range("E2:E" & Sheet1.Range("E" & Rows.Count).End(3).Row).Name = "MyRange1" With Rng.Validation .Delete .Add xlValidateList, xlValidAlertStop, xlBetween, "=MyRange" End With With Rng1.Validation .Delete .Add xlValidateList, xlValidAlertStop, xlBetween, "=MyRange1" End With End Sub اما هذا الكود فيوضع فى فى حدث الورقة "الحافز" لا تنسى حفظ الملف بامتداد آخر حتى تستطيع حفظ الكود Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Target.Column = 3 And Target.Row > 4 Or Target.Column = 5 And _ Target.Row > 4 And Target.Row > 4 Then GetUniqueValues End Sub

السلام عليكم ورحمة الله للاسف على قدر علمى ان هذا الامر يحتاج الى اعمدة مساعدة كثيرة على العمود الدالة المعرفة بالمشاركة السابقة تعمل عمل المعادلات فقط تحتاج حفط الملف بامتداد XLSM مثلا هذا و الله اعلى و اعلم

السلام عليكم ورحمة الله نعم و رقم 7 يدل على عدد الصفوف الخاصة بالمنتجات الستة + صف الاجمالى فى كل مرة ارجو ان تكون قد وصلت الفكرة استخدم المعادلة التالية و اسحبها طولا و عرضا =INDEX($C$2:$G$29;MATCH(K$2;$B$2:$B$28;0)+($L$1-1)*7;MATCH($J3;$C$1:$F$1;0))

السلام عليكم ورحمة الله يمكنك استخدام هذه الدالة المعرفة و هى تعطى الترتيب من الاول حتى العاشر فقط مع التكرار Function RRank(Cel As Range, Rang As Range) As String 'Cel : اول خلية فى نطاق الدرجات ' Rang : -F4- النطاق الذى سوف يتم البحث فيه ويجب تثبيته باستخدام مفتاح '---------------------- Dim Obj As Object, I As Long, Arr As Variant Dim temp As Variant, Itm As Variant, Rnk As Integer Dim x As Integer, k As Integer, MK As String, xx As String '================ Set Obj = CreateObject("Scripting.Dictionary") Arr = Rang.Value For Each Itm In Arr If Obj.exists(Itm) Then Obj.Item(Itm) = Obj.Item(Itm) + 1 Else Obj.Add Itm, 1 End If Next temp = Obj.keys I = Obj.Count '================ If I <= 10 Then k = I Else: k = 10 End If For n = 1 To k Rnk = WorksheetFunction.Large(temp, n) If Cel.Value = Rnk Then If n >= 1 And n <= 10 Then xx = Choose(n, "الاول", "الثانى", "الثالث", "الرابع", "الخامس", _ "السادس", "السابع", "الثامن", "التاسع", "العاشر") trb = xx Else trb = "" End If End If Next '================= m = WorksheetFunction.CountIf(Range(Rang.Cells(1, 1), Cel), Cel) If m > 1 And Cel.Value >= Rnk Then MK = " مكرر" Else MK = "" End If '================= RRank = trb & MK End Function

السلام عليكم ورحمة الله ضع المعادلة الاولى فى الخلية J4 ثم اضغط Ctrl+Shift+ Enter ثم اسحب نزولا لآخر خلية يمكن ظهور بيانات فيها =IFERROR(INDEX($C$4:$D$20;SMALL(IF(LEFT($C$4:$C$20;LEN($H$3))=$H$3;ROW($C$4:$C$20));ROW(A1))-3;1);"") ضع المعادلة الثانية فى الخلية K4 و كرر ماسبق =IFERROR(INDEX($C$4:$D$20;SMALL(IF(LEFT($C$4:$C$20;LEN($H$3))=$H$3;ROW($C$4:$C$20));ROW(B1))-3;2);"") بحث.xlsx

السلام عليكم ورحمة الله اربط هذا الكود بالزر الموجود بالورقة الشهادة Sub PrintCall() Dim ws As Worksheet, Sh As Worksheet, Rng As Range Dim LR As Long, i As Long, p As Long Dim x As Integer, WF As Variant Dim Nam, Sm Set ws = Sheets("بيان") Set Sh = Sheets("شهادة") Set WF = WorksheetFunction LR = ws.Range("B" & Rows.Count).End(3).Row Set Rng = ws.Range("A2:C" & LR) p = 2 x = Sheet6.Shapes("Spinner 3").ControlFormat.Value i = (x - 1) * 4 + 1 Do While p <= 32 Sh.Range("H" & p) = i Nam = WF.VLookup(i, Rng, 2, 0) Sh.Range("C" & p + 2) = Nam Sm = WF.VLookup(i, Rng, 3, 0) Sh.Range("H" & p + 2) = Sm p = p + 10 i = i + 1 Loop ActiveSheet.PrintOut From:=1, To:=1, Copies:=1 End Sub

السلام عليكم ورحمة الله هذا الكود لاستدعاء اسم السيارة بناءا على رقمها اما موضوع تحويل التاريخ من هجرى الى ميلادى اتمنى ان بساعدك فى احد الاخوة لضيق الوقت لدى Sub CarsNames() Dim ws As Worksheet, Sh As Worksheet Dim LR As Long, i As Long Dim Car As String, CarNum As String Dim WF As Variant Set ws = Sheets("Sheet1") Set Sh = Sheets("Plate_No") Set WF = WorksheetFunction LR = ws.Range("A" & Rows.Count).End(xlUp).Row i = 6 Do While i <= LR CarNum = ws.Range("J" & i).Value Car = WF.Index(Sh.Range("A2:B" & Sh.Range("B" & Rows.Count).End(3).Row), _ WF.Match(CarNum, Sh.Range("B2:B" & Sh.Range("B" & Rows.Count).End(3).Row), 0), 1) ws.Range("I" & i) = Car i = i + 1 Loop End Sub

السلام عليكم ورخمة الله تم استخدام Sheet3 كورقة مساعدة يمكنك اخفاءها اذا اردت و قد تركت ظاهرة ليمكنك التعديل عليها اليك الملف كشف بأسماء العاملين بالوحدة.xlsx