محمد هشام.

المعادلات تشتغل معي بشكل جيد وتنفد المطلوب على العموم ادا كنت تقصد انك ترغب بظهور أسماء الأيام باللغة العربية جرب حل اخر كما هو موضح أسفله أسماء الأيام بالعربية =IF(C2="", "", FILTER(CHOOSE(WEEKDAY(FILTER(SEQUENCE(DAY(EOMONTH(C2, 0)), 1, C2, 1), WEEKDAY(SEQUENCE(DAY(EOMONTH(C2, 0)), 1, C2, 1), 1) <= 5), 1), "الأحد", "الإثنين", "الثلاثاء", "الأربعاء", "الخميس", "الجمعة", "السبت"), WEEKDAY(FILTER(SEQUENCE(DAY(EOMONTH(C2, 0)), 1, C2, 1), WEEKDAY(SEQUENCE(DAY(EOMONTH(C2, 0)), 1, C2, 1), 1) <= 5), 1))) التواريخ =IF(C2="", "", FILTER(SEQUENCE(DAY(EOMONTH(C2, 0)), 1, C2, 1), (WEEKDAY(SEQUENCE(DAY(EOMONTH(C2, 0)), 1, C2, 1), 1) <= 5) * (WEEKDAY(SEQUENCE(DAY(EOMONTH(C2, 0)), 1, C2, 1), 1) <> 7))) =EOMONTH(DATE(2024, 9, 1), ROW(A1)-2) + 1 أيام الشهر من يوم محدد.xlsx

وعليكم السلام ورحمة الله تعالى وبركاته بعد ادن الاستاد @أبومروان لتجنب الفراغات يمكنك تجربة هدا الخلية A5 =IF($C$2<>"",TEXT(B5, "dddd"),"") او =IF(C2="", "", FILTER(CHOOSE(WEEKDAY(FILTER(SEQUENCE(DAY(EOMONTH(C2, 0)), 1, C2, 1), WEEKDAY(SEQUENCE(DAY(EOMONTH(C2, 0)), 1, C2, 1), 1) <= 5), 1), "Sunday", "Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday"), WEEKDAY(FILTER(SEQUENCE(DAY(EOMONTH(C2, 0)), 1, C2, 1), WEEKDAY(SEQUENCE(DAY(EOMONTH(C2, 0)), 1, C2, 1), 1) <= 5), 1))) الخلية B5 =IF(C2="", "", FILTER(SEQUENCE(DAY(EOMONTH(C2, 0)), 1, C2, 1), (WEEKDAY(SEQUENCE(DAY(EOMONTH(C2, 0)), 1, C2, 1), 1) <= 5))) لانشاء قائمة شهور السنة =EOMONTH(DATE(2024, 1, 1), ROW(A1)-2) + 1 أيام الشهر من يوم محدد.xlsx

بسيطة 😉 سوف أحاول تعديل الأكواد السابقة على هذا الملف بطريقة مختلفة لتتمكن من عرض البيانات بالشكل المطلوب مع بعض التحسينات تفضل اخي @عادل ابوزيد Option Explicit Private Const Mysh_Name As String = "البداية" Private Const MyFind_Column As Integer = 5 Private Const iHeight As Integer = 20 Private iGblInhibitTextBoxEvents As Boolean Private Sub UserForm_Initialize() kh_Add_Labels Me.Frame2, 5 Me.Frame2.BorderStyle = 0 End Sub Private Sub kh_Add_Controls(MyCont As Control, MyTop As Double, MyHeight As Double, iRo As Long, rowData() As String) Dim MyTxt As Control Dim i As Integer Dim tmp As Double Dim Colarr(1 To 12) As Double Dim columnHeights(1 To 12) As Double Dim defaultWidths As Variant defaultWidths = Array(68, 80, 80, 130, 170, 110, 80, 90, 80, 80, 80, 115) For i = 1 To 12 Colarr(i) = defaultWidths(i - 1) columnHeights(i) = 25 Next i tmp = 0 For i = UBound(rowData) To 1 Step -1 Set MyTxt = MyCont.Add("Forms.TextBox.1", Cells(iRo, 3 + i - 1).Address, True) With MyTxt .Move tmp, MyTop, Colarr(i), columnHeights(i) .Text = rowData(i) .TextAlign = fmTextAlignRight .Font.Size = 13 .Font.Name = "Times New Roman" .BorderStyle = fmBorderStyleSingle .BorderColor = RGB(128, 128, 128) End With tmp = tmp + Colarr(i) + 0.15 Next i Set MyTxt = Nothing End Sub Private Sub kh_Add_Labels(MyCont As Control, MyTop As Double) Dim i As Integer Dim MyLabel As Control Dim tmp As Double Dim Colarr(1 To 12) As Double Dim defaultWidths As Variant defaultWidths = Array(72, 80, 80, 130, 170, 110, 80, 90, 80, 80, 80, 115) For i = 1 To 12 Colarr(i) = defaultWidths(i - 1) Next i Dim spacing As Double spacing = 0.15 tmp = 0 For i = 12 To 1 Step -1 Set MyLabel = MyCont.Add("Forms.Label.1", "Label" & i, True) With MyLabel .Caption = Worksheets("البداية").Cells(6, 3 + i - 1).Value .Move tmp, MyTop, Colarr(i), 20 .TextAlign = fmTextAlignCenter .Font.Size = 14 .Font.Name = "Times New Roman" .BorderStyle = fmBorderStyleSingle .BorderColor = RGB(192, 192, 192) .BackColor = RGB(51, 204, 204) End With tmp = tmp + Colarr(i) + spacing Next i Set MyLabel = Nothing End Sub Private Sub kh_Find(MyText As String) Dim MyHght As Double, MyTp As Double Dim Last As Long, ii As Long, i As Long Dim Found As Boolean Found = False MyTp = 0 Application.ScreenUpdating = False With Worksheets(Mysh_Name) Last = .Cells(.Rows.Count, MyFind_Column).End(xlUp).Row For ii = 2 To Last If CStr(.Cells(ii, MyFind_Column)) Like IIf(Me.Check_Text.Value, "", "*") & MyText & "*" Then MyHght = .Rows(ii).RowHeight Dim rowData(1 To 12) As String For i = 3 To 14 If i = 4 Or i = 9 Or i = 11 Or i = 12 Or i = 13 Then If IsDate(.Cells(ii, i).Value) Then rowData(i - 2) = Format(.Cells(ii, i).Value, "yyyy/mm/dd") Else rowData(i - 2) = CStr(.Cells(ii, i).Value) End If Else rowData(i - 2) = CStr(.Cells(ii, i).Value) End If Next i If MyHght < iHeight Then MyHght = iHeight kh_Add_Controls Me.Frame1, MyTp, MyHght, .Cells(ii, MyFind_Column).Row, rowData MyTp = MyTp + MyHght + 2 Found = True End If Next End With If Not Found Then MsgBox TextBox_Find.Value & " " & "رقم الملف غير موجود", vbExclamation Me.TextBox_Find.Value = "" End If If MyTp >= Me.Frame1.Height Then Me.Frame1.ScrollHeight = MyTp Application.ScreenUpdating = True End Sub تنسيق الفورم.rar

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

وعليكم السلام ورحمة الله تعالى وبركاته تم تعديل الاكواد لتتناسب مع طلبك مع تغيير طريقة تعديل البيانات ليتم تنفيدها عند الظغط على زر التعديل Option Explicit Private Const Mysh_Name As String = "البداية" Private Const MyFind_Column As Integer = 5 Private Const iHeight As Integer = 20 Private Sub kh_Add_Controls(MyCont As Control, MyTop As Double, MyHeight As Double, iRo As Long, rowData() As String) Dim MyTxt As Control Dim i As Integer For i = 1 To UBound(rowData) Set MyTxt = MyCont.Add("Forms.TextBox.1", Cells(iRo, i + 2).Address, True) With MyTxt .Move MyCont.Controls(i - 1).Left, MyTop, MyCont.Controls(i - 1).Width, MyHeight .MultiLine = True .Text = rowData(i) End With With Worksheets(Mysh_Name).Cells(iRo, i + 2) MyTxt.TextAlign = Me.kh_TextAlign(.HorizontalAlignment) MyTxt.Font.Bold = .Font.Bold MyTxt.Font.Size = .Font.Size MyTxt.FontName = .Font.Name End With Next i Set MyTxt = Nothing End Sub Private Sub kh_Find(MyText As String) ' البحث Dim MyHght As Double, MyTp As Double Dim Last As Long, ii As Long Dim Found As Boolean Found = False With Me.Frame1 MyTp = .Controls(0).Top + .Controls(0).Height + 2 End With Application.ScreenUpdating = False With Worksheets(Mysh_Name) Last = .Cells(.Rows.Count, MyFind_Column).End(xlUp).Row For ii = 2 To Last If CStr(.Cells(ii, MyFind_Column)) Like IIf(Me.Check_Text.Value, "", "*") & MyText & "*" Then MyHght = .Rows(ii).RowHeight Dim rowData(1 To 12) As String 'الأعمدة من C إلى N Dim i As Integer For i = 3 To 14 If i = 4 Or i = 9 Or i = 11 Or i = 12 Or i = 13 Then ' D, I, K, L, M If IsDate(.Cells(ii, i).Value) Then rowData(i - 2) = Format(.Cells(ii, i).Value, "yyyy/mm/dd") Else rowData(i - 2) = CStr(.Cells(ii, i).Value) End If Else rowData(i - 2) = CStr(.Cells(ii, i).Value) End If Next i If MyHght < iHeight Then MyHght = iHeight kh_Add_Controls Me.Frame1, MyTp, MyHght, .Cells(ii, MyFind_Column).Row, rowData MyTp = MyTp + MyHght + 2 Found = True End If Next End With If Not Found Then MsgBox TextBox_Find.Value & " " & "رقم الملف غير موجود", vbExclamation Me.TextBox_Find.Value = "" End If If MyTp >= Me.Frame1.Height Then Me.Frame1.ScrollHeight = MyTp Application.ScreenUpdating = True End Sub Private Function FormatDate(dateValue As Variant) As String If IsDate(dateValue) Then FormatDate = Format(dateValue, "yyyy/mm/dd") Else FormatDate = "" End If End Function Private Sub Button_Save_Click() ' تعديل البيانات If Me.TextBox_Find.Value = "" Then Exit Sub Application.ScreenUpdating = False Application.EnableEvents = False Application.Calculation = xlCalculationManual Dim MyCon As Control Dim cellAddress As String Dim cellValue As String On Error Resume Next For Each MyCon In Me.Frame1.Controls If TypeName(MyCon) = "TextBox" Then cellAddress = MyCon.Name cellValue = MyCon.Text Worksheets(Mysh_Name).Range(cellAddress).Value = cellValue End If Next MyCon On Error GoTo 0 Application.ScreenUpdating = True Application.EnableEvents = True Application.Calculation = xlCalculationAutomatic MsgBox "تم حفظ التعديلات بنجاح", vbInformation End Sub Private Sub kh_Remove() On Error Resume Next Dim MyCon As Control Me.Frame1.ScrollHeight = 0 For Each MyCon In Me.Frame1.Controls If TypeName(MyCon) = "TextBox" Then Me.Frame1.Controls.Remove MyCon.Name End If Next MyCon On Error GoTo 0 End Sub Private Sub Button_Find_Click() If Me.TextBox_Find.Value = "" Then MsgBox "يرجى إظافة رقم الملف", vbInformation: Exit Sub kh_Remove If Len(Trim(Me.TextBox_Find.Text)) Then kh_Find Me.TextBox_Find End If End Sub Private Sub TextBox_Find_Change() kh_Remove End Sub Function kh_TextAlign(MyAlign) As Integer Dim Ag Dim A As Integer For A = 1 To 3 Ag = Choose(A, -1131, -1108, -1152) If Ag = MyAlign Then kh_TextAlign = A: Exit Function Next kh_TextAlign = 1 End Function تنسيق الفورم.rar

وعليكم السلام ورحمة الله تعالى وبركاته للحصول على النتائج بالترتيب المطلوب يمكنك استخدام الصيغة التالية للحصول على الأسماء التي تتضمن القيمة ب USD في الخلية A3 =UNIQUE(FILTER(Sheet1!A2:A45, Sheet1!G2:G45<>"")) وفي الخلية C3 =IF(A3<>"", SUMIFS(Sheet1!$G$2:$G$45, Sheet1!$A$2:$A$45, A3), "") مع سحبها لغاية اخر صف به بيانات من الأسماء المستخرجة وبعد اخر صف به بيانات على العمود A ضع المعادلة التالية لجلب الأسماء التي تتضمن EGP =UNIQUE(FILTER(Sheet1!A2:A45, Sheet1!F2:F45<>"")) وبنفس الطريقة في اخر خلية بها بيانات من عمود C =IF(A16<>"", SUMIFS(Sheet1!$F$2:$F$45, Sheet1!$A$2:$A$45, A16), "") Suppliers.xlsx أنصحك أخي @هانى محمد باستخدام الأكواد لتتمكن من الحصول على النتائج المطلوبة بطريقة ديناميكية دون تقييد لخلايا وضع المعادلات خاصة ادا كانت البيانات غير ثابتة وقابلة للزيادة مما سوف يساعدك على الإشتغال على الملف بشكل مرن ومطاطي وحصولك على النتائج بالترتيب المطلوب جرب هدا Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim LastRow As Long, n As Long, a As Collection, b As Collection Dim TotalG As Double, TotalF As Double, Kay As Variant, rng As Range Dim ColG As Variant, ColF As Variant, i As Long Dim Irow As Long, j As Variant, totals As Variant Dim WS As Worksheet: Set WS = Sheets("Sheet1") Dim dest As Worksheet: Set dest = Sheets("Total") If Not Intersect(Target, WS.Range("A2:G" & WS.Rows.Count)) Is Nothing Then Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False On Error Resume Next Dim tbl As ListObject Set tbl = dest.ListObjects(1) If Not tbl Is Nothing Then tbl.Unlist End If On Error GoTo 0 LastRow = dest.Cells(dest.Rows.Count, "A").End(xlUp).Row If LastRow >= 3 Then dest.Range("A3:D" & LastRow).Clear End If If dest.Cells(2, "A").Value = "" Then dest.Range("A2:D2").Value = Array("Supplier Name", "Cheque Name", "Amount", "Curr") End If LastRow = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row ColG = Application.Transpose(WS.Range("G2:G" & LastRow).Value) ColF = Application.Transpose(WS.Range("F2:F" & LastRow).Value) Set a = New Collection: Set b = New Collection On Error Resume Next For i = 2 To LastRow If ColG(i - 1) <> "" Then a.Add WS.Cells(i, "A").Value, CStr(WS.Cells(i, "A").Value) If ColF(i - 1) <> "" Then b.Add WS.Cells(i, "A").Value, CStr(WS.Cells(i, "A").Value) Next i On Error GoTo 0 n = 3 For Each Kay In a dest.Cells(n, "A").Value = Kay dest.Cells(n, "C").Value = Application.WorksheetFunction.SumIf _ (WS.Range("A2:A" & LastRow), Kay, WS.Range("G2:G" & LastRow)) dest.Cells(n, "D").Value = "USD" TotalG = TotalG + dest.Cells(n, "C").Value n = n + 1 Next Kay For Each Kay In b dest.Cells(n, "A").Value = Kay dest.Cells(n, "C").Value = Application.WorksheetFunction.SumIf _ (WS.Range("A2:A" & LastRow), Kay, WS.Range("F2:F" & LastRow)) dest.Cells(n, "D").Value = "EGP" TotalF = TotalF + dest.Cells(n, "C").Value n = n + 1 Next Kay totals = Array("Total USD", TotalG, "Total EGP", TotalF) n = n + 1 j = Array("USD", "EGP") For i = LBound(totals) To UBound(totals) Step 2 dest.Cells(n + (i / 2), "A").Value = totals(i) dest.Cells(n + (i / 2), "C").Value = totals(i + 1) dest.Cells(n + (i / 2), "D").Value = j(i / 2) Next i For i = 3 To n - 1 dest.Cells(i, "C").NumberFormat = "_(* #,##0.00_);_(* (#,##0.00);_(* ""-""??_);_(@_)" Next i Irow = n + (UBound(totals) \ 2) Set tbl = dest.ListObjects.Add(xlSrcRange, dest.Range("A2:D" & Irow), , xlYes) tbl.Name = "ResultsTable" tbl.TableStyle = "TableStyleLight19" For i = Irow - 2 To Irow - 1 With tbl.Range.Rows(i).Borders .LineStyle = xlContinuous .Color = RGB(0, 0, 0) .Weight = xlMedium End With Next i Set rng = dest.Range("D3:D" & n - 1) With rng.FormatConditions.Add(Type:=xlCellValue, Operator:=xlEqual, Formula1:="=""EGP""") .Interior.Color = RGB(255, 192, 203) .Font.Color = RGB(255, 0, 0) End With With tbl.Range.Columns("B:D") .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter End With Application.EnableEvents = True Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End If End Sub Suppliers VBA .xlsb

العفو اخي يسعدنا أننا إستطعنا مساعدتك

ليس هناك مستحيل اخي @عبد الرحمن أشرف يمكننا إظافة دالة جديدة مع الحفاظ على الأولى لتتمكن من إختيار ما يناسبك الدالة الجديدة مع التفقيط Option Explicit Function CalcAgeArabic(vDate1 As Variant, vDate2 As Variant, ByVal resultType As String) As Variant Dim vYears As Integer, vMonths As Integer, vDays As Integer If IsEmpty(vDate1) Or IsEmpty(vDate2) Then CalcAgeArabic = "" Exit Function End If If Not IsDate(vDate1) Or Not IsDate(vDate2) Then CalcAgeArabic = CVErr(xlErrValue) Exit Function End If If vDate2 < vDate1 Then MsgBox "التاريخ الثاني يجب أن يكون أكبر من الأول" CalcAgeArabic = CVErr(xlErrValue) Exit Function End If vYears = Year(vDate2) - Year(vDate1) vMonths = Month(vDate2) - Month(vDate1) vDays = Day(vDate2) - Day(vDate1) If vDays < 0 Then vMonths = vMonths - 1 Dim lastMonth As Date lastMonth = DateAdd("m", -1, vDate2) vDays = Day(DateSerial(Year(lastMonth), Month(lastMonth) + 1, 1) - 1) + vDays End If If vMonths < 0 Then vYears = vYears - 1 vMonths = vMonths + 12 End If Select Case resultType Case "Days" CalcAgeArabic = NumberToArabicWords(vDays) & " يوم" Case "Months" CalcAgeArabic = NumberToArabicWords(vMonths) & " شهور" Case "Years" CalcAgeArabic = NumberToArabicWords(vYears) & " سنوات" Case "Days and Months" CalcAgeArabic = NumberToArabicWords(vMonths) & " شهور و " & NumberToArabicWords(vDays) & " يوم" Case "Years and Months" CalcAgeArabic = NumberToArabicWords(vYears) & " سنوات و " & NumberToArabicWords(vMonths) & " شهور" Case "Years, Months, Days" CalcAgeArabic = NumberToArabicWords(vYears) & " سنوات و " & NumberToArabicWords(vMonths) & " شهور و " & _ NumberToArabicWords(vDays) & " يوم" Case Else CalcAgeArabic = "صيغة الدالة غير معروفة" End Select End Function Function NumberToArabicWords(ByVal Number As Integer) As String Select Case Number Case 1: NumberToArabicWords = "واحد" Case 2: NumberToArabicWords = "اثنان" Case 3: NumberToArabicWords = "ثلاثة" Case 4: NumberToArabicWords = "أربعة" Case 5: NumberToArabicWords = "خمسة" Case 6: NumberToArabicWords = "ستة" Case 7: NumberToArabicWords = "سبعة" Case 8: NumberToArabicWords = "ثمانية" Case 9: NumberToArabicWords = "تسعة" Case 10: NumberToArabicWords = "عشرة" Case 11: NumberToArabicWords = "أحد عشر" Case 12: NumberToArabicWords = "اثنا عشر" Case 13: NumberToArabicWords = "ثلاثة عشر" Case 14: NumberToArabicWords = "أربعة عشر" Case 15: NumberToArabicWords = "خمسة عشر" Case 16: NumberToArabicWords = "ستة عشر" Case 17: NumberToArabicWords = "سبعة عشر" Case 18: NumberToArabicWords = "ثمانية عشر" Case 19: NumberToArabicWords = "تسعة عشر" Case 20: NumberToArabicWords = "عشرون" Case 21: NumberToArabicWords = "واحد وعشرون" Case 22: NumberToArabicWords = "اثنان وعشرون" Case 23: NumberToArabicWords = "ثلاثة وعشرون" Case 24: NumberToArabicWords = "أربعة وعشرون" Case 25: NumberToArabicWords = "خمسة وعشرون" Case 26: NumberToArabicWords = "ستة وعشرون" Case 27: NumberToArabicWords = "سبعة وعشرون" Case 28: NumberToArabicWords = "ثمانية وعشرون" Case 29: NumberToArabicWords = "تسعة وعشرون" Case 30: NumberToArabicWords = "ثلاثون" Case Else: NumberToArabicWords = CStr(Number) End Select End Function حساب الفرق بين تاريخين - بالتفقيط (1).xlsm

بكل سرور اخي @عبد الرحمن أشرف يكفي تعديل بسيط على الدالة Select Case resultType Case "Days" CalcAge = vDays Case "Months" CalcAge = vMonths Case "Years" CalcAge = vYears Case "Days and Months" CalcAge = vMonths & " شهور و " & vDays & " يوم" Case "Years and Months" CalcAge = vYears & " سنوات و " & vMonths & " شهور" Case "Years, Months, Days" CalcAge = Trim(vYears & " سنوات و " & vMonths & " شهور و " & vDays & " يوم") Case Else CalcAge = "صيغة الدالة غير معروفة" End Select و التأكد من إعدادات المحاذاة للخلايا حساب الفرق بين تاريخين - بالعربية .xlsm

جرب هل هدا ما تقصده حساب الفرق بين تاريخين - محمد هشام.xlsm

تفضل جرب هدا Private Sub CommandButton1_Click() Dim ws As Worksheet, src As Range, i As Long Dim arr() As Variant, columns() As Variant Dim Code As String, lastrow As Long, exists As Long Set ws = Sheets("التكويد") lastrow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row Code = Me.TextBox4.Value If Code = "" Then: MsgBox "الرجاء إدخال كود الصنف", vbExclamation, "خطأ": Exit Sub exists = WorksheetFunction.CountIf(ws.Range("a2:a" & lastrow), Code) If exists > 0 Then: MsgBox "كود الصنف موجود مسبقا", vbExclamation, "إنتبـــاه": Me.TextBox4.Value = "": Exit Sub With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With Set src = ws.Range("A" & ws.Rows.Count).End(xlUp).Offset(1, 0) columns = Array("A", "B", "C", "D", "F", "G", "H") arr = Array(Me.TextBox4.Value, Me.TextBox1.Value, Me.TextBox7.Value, Me.TextBox2.Value, _ Me.TextBox3.Value, Me.TextBox5.Value, Me.TextBox6.Value) For i = LBound(arr) To UBound(arr) If i <= UBound(columns) Then ws.Cells(src.Row, columns(i)).Value = arr(i) End If Next i For Each ctrl In Me.Controls If TypeName(ctrl) = "TextBox" Then ctrl.Value = "" End If Next ctrl With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With MsgBox "تم إدخال البيانات بنجاح", vbInformation, "نجاح" End Sub عدم تكرار .xlsm

وعليكم السلام ورحمة الله تعالى وبركاته جرب هل هدا ما تقصده Option Explicit Sub FindMaxClass() Dim tmp As Double Dim i&, kay&, n&, lastRow Dim WS As Worksheet: Set WS = Sheets("Sheet1") lastRow = WS.Cells(WS.Rows.Count, 2).End(xlUp).Row tmp = Application.WorksheetFunction.Max(WS.Range("B2:B" & lastRow)) n = 0 For i = 2 To lastRow If WS.Cells(i, 2).value = tmp Then If WS.Cells(i, 1).value > n Then n = WS.Cells(i, 1).value End If End If Next i kay = n WS.Range("E1").Resize(1, 2).value = Array(kay, tmp) End Sub لتنفيد الكود مباشرة عند التغيير في أحد الأعمدة Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim WS As Worksheet Set WS = Me If Not Intersect(Target, WS.Range("A:B")) Is Nothing Then If Target.Row > 1 Then Dim i As Long, kay As Long, lastRow As Long Dim a As Variant, tmp As Double lastRow = WS.Cells(WS.Rows.Count, 2).End(xlUp).Row a = WS.Range("A2:B" & lastRow).value tmp = Application.WorksheetFunction.Max(Application.Index(a, 0, 2)) kay = 0 For i = LBound(a, 1) To UBound(a, 1) If a(i, 2) = tmp Then If a(i, 1) > kay Then kay = a(i, 1) End If End If Next i WS.Range("E1").Resize(1, 2).value = Array(kay, tmp) End If End If End Sub test1.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته الملف مليئ بالاكواد ممكن توضح الكود بالظبط او اسم اليوزرفورم المطلوب التعديل عليه

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا =IFERROR(IF(A14="","",LOOKUP(2,1/(INDEX($B$2:$E$9,MATCH(A14,$A$2:$A$9,0),0)<>""),INDEX($B$2:$E$9,MATCH(A14,$A$2:$A$9,0),0))),"بدون نتيجة") أو بإستخدام vba Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim Code As Variant, dataA As Variant, dataB As Variant Dim rngA As Range, rngB As Range, rngC As Range Dim tmp As Variant, result As String Dim cell As Range, col As Long Dim msg As String: msg = "بدون نتيجة" Set rngA = Me.Range("A2:A9") Set rngB = Me.Range("B2:E9") Set rngC = Me.Range("A14:A21") Application.ScreenUpdating = False Application.EnableEvents = False On Error GoTo CleanExit If Not Intersect(Target, Union(rngB, rngC)) Is Nothing Then dataA = rngA.Value dataB = rngB.Value For Each cell In rngC If Trim(cell.Value) <> "" Then tmp = Application.Match(cell.Value, rngA, 0) If Not IsError(tmp) Then result = msg For col = 4 To 1 Step -1 If Trim(dataB(tmp, col)) <> "" Then result = dataB(tmp, col) Exit For End If Next col cell.Offset(0, 1).Value = result Else Code = cell.Value cell.Resize(1, 2).ClearContents MsgBox "الكود " & Code & " غير موجود", vbExclamation End If Else cell.Offset(0, 1).ClearContents End If Next cell End If CleanExit: Application.EnableEvents = True Application.ScreenUpdating = True End Sub ppp.xlsb

يمكنك تنفيد نفس الأمر بواسطة الأكواد Private Sub Worksheet_Change(ByVal Target As Range) Dim Rng As Variant, a() As Variant, Irow As Long Dim i As Long, lastRow As Long, j As Long Dim WS As Worksheet: Set WS = Sheets("Sheet1") Dim dest As Worksheet: Set dest = Sheets("Sheet2") If Not Intersect(Target, Me.Range("A8:A1000", "C8:D1000")) Is Nothing Then Application.EnableEvents = False Irow = dest.Cells(dest.Rows.Count, "B").End(xlUp).Row If Irow >= 2 Then dest.Range("B2:B" & Irow).ClearContents End If lastRow = WS.Cells(WS.Rows.Count, "C").End(xlUp).Row If lastRow < 8 Then Exit Sub Rng = WS.Range("A8:D" & lastRow).Value ReDim a(1 To UBound(Rng), 1 To 1) j = 1 For i = 1 To UBound(Rng, 1) If Rng(i, 3) = "1/1" And Rng(i, 4) = "ذكر" Then a(j, 1) = Rng(i, 1) j = j + 1 End If Next i If j > 1 Then dest.Range("B2").Resize(j - 1, 1).Value = a End If End If Application.EnableEvents = True End Sub vba المعادلة.xlsb

إذا كنت تستخدم إصدار قديم بعد وضع المعادلة اضغط على Ctrl + Shift + Enter لتفعيلها كصيغة مصفوفة

وعليكم السلام ورحمة الله تعالى وبركاته إذا كنت تستخدم اصدارات حديثة من اللأوفيس يمكنك استخدام دالة FILTER للحصول على النتائج إذا لم تكن لديك هذه الإصدارات يمكنك استخدام دالة IF مع INDEX و SMALL سنقوم مثلا باستخراج البيانات من Sheet1 ووضعها في Sheet2 في أول خلية لعمود النتائج على Sheet2 =FILTER(Sheet1!A8:A100, (Sheet1!C8:C100="1/1")*(Sheet1!D8:D100="ذكر")) او =IFERROR(INDEX(Sheet1!A$8:A$100, SMALL(IF((Sheet1!C$8:C$100="1/1")*(Sheet1!D$8:D$100="ذكر"), ROW(Sheet1!A$8:A$100)-ROW(Sheet1!A$8)+1), ROW(1:1)), 1), "") مع سحب المعادلة للأسفل بهذه الطريقة يمكنك استخراج القيم المطلوبة دون ترك صفوف فارغة بين النتائج المعادلة.xlsx

أخي @صباح2024 إدا كنت قد إستوعبت طلبك سنقوم بتعديل الكود بطريقة مختلفة لنتمكن من تنفيد المطلوب بشكل دقيق لان دمج الاكواد على Private Sub Worksheet_Change(ByVal Target As Range) والإشتغال عليها مباشرة من شأنه أن يسبب لك عدة مشاكل خاصة انك ترغب بتحديث البيانات عند كل تغيير على اي خلية لنفترض أنك قمت باسـتدعاء اي اسم مثلا من الطبيعي ان البيانات السابقة مختلفة بمجرد استدعائها سيتم نسخها للاعمدة الخاصة بالاسم الدي تم اختياره مما سيسبب لك تلف وتعارض في البيانات اسف على الإطالة لاكن لابد من توضيح الفكرة ( اليك ما تم الإشتغال عليه) 1) جلب البيانات من ورقة السجل الى ورقة استدعاء بشرط الإسم 2) تحديث البيانات عند التغيير في أي خلية من الخلايا التي تم تمييزها باللون الأصفر على ورقة استدعاء على الأعمدة المناسبة في ورقة السجل مع مراعات الإسم 3) تم اظافة كود لإنشاء قائمة منسدلة ديناميكية بالأسماء الفريدة من العمود B ( ورقة السجل) بداية من الصف 2 تلقائيا في خلية الإسم (B6) ورقة استدعاء الأكواد المستخدمة : Public Property Get WS() As Worksheet Set WS = Sheets("استدعاء") End Property Public Property Get dest() As Worksheet Set dest = Sheets("السجل") End Property ' خلية الإسم Public Function Clé() As String Clé = WS.Range("B6").Value End Function 'نطاق البحث Public Function rng() As Range Set rng = dest.Range("B2:B" & dest.Cells(dest.Rows.Count, 2).End(xlUp).Row) End Function '======================== ' جلب البيانات من ورقة السجل إلى ورقة "استدعاء" Sub Fetch_data() Dim data As Variant, i As Long, tmp As Range Application.ScreenUpdating = False On Error GoTo CleanExit Set tmp = rng.Find(Clé, LookIn:=xlValues, LookAt:=xlWhole) If tmp Is Nothing Then MsgBox "لم يتم العثور على الإسم" & " : " & Clé & " في السجل", vbExclamation Exit Sub End If For i = 0 To 3 data = dest.Range(tmp.Offset(0, 1 + (i * 9)), tmp.Offset(0, 9 + (i * 9))).Value WS.Range("A" & (9 + (i * 3)) & ":I" & (9 + (i * 3))).Value = data Next i CleanExit: Application.ScreenUpdating = True End Sub '======================== ' تحديث البيانات من ورقة استدعاء الى ورقة السجل Sub Update_data() Dim tmp As Range, cnt() As Variant, OnRng As Range Dim ColArr() As Long, j As Long, i As Long Set OnRng = rng.Find(Clé, LookIn:=xlValues, LookAt:=xlWhole) If OnRng Is Nothing Then MsgBox "لم يتم العثور على الإسم" & " : " & Clé & " في السجل", vbExclamation Exit Sub End If Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Dim Irow As Long Irow = OnRng.Row ReDim ColArr(0 To 35) For j = 0 To 35 ColArr(j) = j + 3 Next j ReDim cnt(UBound(ColArr)) For i = 0 To UBound(cnt) cnt(i) = WS.Cells(9 + (i \ 9) * 3, 1 + (i Mod 9)).Value Next i For i = 0 To UBound(ColArr) If dest.Cells(Irow, ColArr(i)).Value <> cnt(i) Then dest.Cells(Irow, ColArr(i)).Value = cnt(i) End If Next i Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub '======================== ' إضافة قائمة منسدلة بالأسماء المتوفرة في ورقة "السجل" Sub Add_listeDéroulante() Dim lr As Long, arr() As String, r As Range, i As Long Dim cnt As New Collection, Names As Range lr = dest.Cells(dest.Rows.Count, 2).End(xlUp).Row On Error Resume Next For Each r In rng If r.Value <> "" Then cnt.Add r.Value, CStr(r.Value) End If Next r On Error GoTo 0 If cnt.Count = 0 Then Exit Sub ReDim arr(1 To cnt.Count) For i = 1 To cnt.Count arr(i) = cnt(i) Next i Set Names = WS.Range("B6") With Names.Validation .Delete .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _ xlBetween, Formula1:=Join(arr, ",") .IgnoreBlank = True: .InCellDropdown = True: .ShowInput = True: .ShowError = True End With End Sub وفي حدث ورقة استدعاء Private Sub Worksheet_Activate() Add_listeDéroulante End Sub Private Sub Worksheet_Change(ByVal Target As Range) Dim Clé As Range, cntArr As Range Set Clé = WS.Range("B6") If Clé.Value = "" Then Exit Sub If Target.Address = Clé.Address Then On Error GoTo ErrorHandler Fetch_data Exit Sub End If ' عناوين الخلايا المستهدفة Set cntArr = Me.Range("A9:I9, A12:I12, A15:I15, A18:I18") If Not Intersect(Target, cntArr) Is Nothing Then On Error GoTo ErrorHandler Update_data Exit Sub End If Exit Sub ErrorHandler: MsgBox "حدث خطأ: " & Err.Description On Error GoTo 0 End Sub وأي إستفسار سنكون دائما سعداء بمساعدتك تحويل التغييرات من شيت الاستدعاء الى شيت السجل.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته تفضل أخي تم تنفيد طلبك بنفس الفكرة إستخراج الأرقام المكررة مع ترحيل التقرير لورقة2 يتضمن إسم الصنف - القيمة المكررة - عدد التكرارات Const Item As Long = 2 ' تحديد أدنى عدد للتكرارات المطلوبة Sub Find_DuplicatedNumbers() Dim WS As Worksheet, dest As Worksheet Dim CodeArr() As Variant, f() As Variant, code As Variant Dim tmp As Object, ligne As Long, a As Long Dim lastRow As Long, i As Long, key As Variant Dim dict As Object, n As Boolean Dim Rng As Range, c As Range, LR As Long Set WS = Sheets("Sheet1") Set dest = Sheets("Sheet2") lastRow = WS.Cells(WS.Rows.Count, 1).End(xlUp).Row On Error Resume Next CodeArr = WS.Range("A3:A" & lastRow).Value f = WS.Range("B3:B" & lastRow).Value Set tmp = CreateObject("Scripting.Dictionary") For i = 1 To UBound(CodeArr, 1) If Not tmp.Exists(CodeArr(i, 1)) Then tmp.Add CodeArr(i, 1), CreateObject("Scripting.Dictionary") End If On Error GoTo 0 If tmp(CodeArr(i, 1)).Exists(f(i, 1)) Then tmp(CodeArr(i, 1))(f(i, 1)) = tmp(CodeArr(i, 1))(f(i, 1)) + 1 Else tmp(CodeArr(i, 1))(f(i, 1)) = 1 End If Next i n = False For Each code In tmp.Keys Set dict = tmp(code) For Each key In dict.Keys If dict(key) >= Item Then n = True Exit For End If Next key If n Then Exit For Next code If Not n Then MsgBox "لا توجد أي تكرارات للقيم", vbInformation: Exit Sub Application.ScreenUpdating = False LR = WS.Cells(WS.Rows.Count, "F").End(xlUp).Row WS.Range("F3:G" & LR).Borders.LineStyle = xlNone dest.Range("A2:C" & dest.Rows.Count).ClearContents WS.Range("F3:G" & WS.Rows.Count).ClearContents dest.Cells(2, 1).Resize(1, 3).Value = Array("كود الصنف", "القيمة المكررة", "عدد مرات التكرار") ligne = 3 a = 3 For Each code In tmp.Keys Set dict = tmp(code) For Each key In dict.Keys If dict(key) >= Item Then WS.Cells(ligne, 6).Value = code WS.Cells(ligne, 7).Value = key ligne = ligne + 1 dest.Cells(a, 1).Resize(1, 3).Value = Array(code, key, dict(key)) a = a + 1 End If Next key Next code LR = WS.Cells(WS.Rows.Count, "F").End(xlUp).Row Set Rng = WS.Range("F3:G" & LR) For Each c In Rng.Rows If Application.WorksheetFunction.CountA(c) > 0 Then c.Borders.LineStyle = xlContinuous End If Next c Application.ScreenUpdating = True MsgBox dest.Name & " تم ترحيل ملخص الأرقام المكررة إلى", vbInformation End Sub الأرقام المكررة.xlsb

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

تفضل أخي Sub Find_MissingNumbers3() Dim WS As Worksheet, dest As Worksheet Dim CodeArr() As Variant, NumArr() As Variant, code As Variant Dim tmp As Object, ling As Long, cnt As Boolean, n As Boolean Dim lastRow As Long, i As Long, j As Long, maxNum As Long Dim msg As String, KyCount As Long Set WS = Sheets("Sheet1") Set dest = Sheets("Sheet2") lastRow = WS.Cells(WS.Rows.Count, 1).End(xlUp).Row maxNum = 100 ' تحديد الحد الاقصى للقيم المفقودة n = False For i = 3 To lastRow If Not IsEmpty(WS.Cells(i, 1).Value) And Not IsEmpty(WS.Cells(i, 2).Value) Then n = True Exit For End If Next i If Not n Then MsgBox "الرجاء التحقق من البيانات والمحاولة مرة أخرى", vbExclamation Exit Sub End If Application.ScreenUpdating = False dest.Range("a2:b" & dest.Rows.Count).ClearContents WS.Range("F3:G" & WS.Rows.Count).ClearContents CodeArr = WS.Range("A3:A" & lastRow).Value NumArr = WS.Range("B3:B" & lastRow).Value Set tmp = CreateObject("Scripting.Dictionary") For i = 1 To UBound(CodeArr, 1) If Not tmp.Exists(CodeArr(i, 1)) Then tmp.Add CodeArr(i, 1), New Collection End If tmp(CodeArr(i, 1)).Add NumArr(i, 1) Next i dest.Cells(2, 1).Value = "كود الصنف" dest.Cells(2, 2).Value = "عدد الأرقام المفقودة" ling = 3 Dim a As Long a = 3 For Each code In tmp.Keys KyCount = 0 For j = 1 To maxNum cnt = False For i = 1 To tmp(code).Count If tmp(code)(i) = j Then cnt = True Exit For End If Next i If Not cnt Then WS.Cells(ling, 6).Value = code WS.Cells(ling, 7).Value = j ling = ling + 1 KyCount = KyCount + 1 End If Next j dest.Cells(a, 1).Value = code dest.Cells(a, 2).Value = KyCount a = a + 1 Next code Application.ScreenUpdating = True MsgBox dest.Name & " تم ترحيل ملخص الأرقام المفقودة إلى", vbInformation End Sub الأرقام الناقصة v2.xlsb

جرب وضع هدا في Module Option Explicit Sub TestUpdate() Dim dest As Worksheet, WS As Worksheet Dim Clé As String, i As Integer Dim tmp As Range, cnt As Variant Dim Irow As Long, ColArr As Variant, rng As Range Set WS = Sheets("استدعاء") Set dest = Sheets("السجل") Clé = WS.Range("B8").Value If Clé = "" Then Exit Sub Set rng = dest.Range("B2:B" & dest.Cells(dest.Rows.Count, 2).End(xlUp).Row) Set tmp = rng.Find(Clé, LookIn:=xlValues, lookat:=xlWhole) If tmp Is Nothing Then MsgBox "لم يتم العثور على الإسم في السجل", vbExclamation Exit Sub End If Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Irow = tmp.Row ColArr = Array(8, 9, 10, 14, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29) cnt = Array(WS.Range("A12").Value, WS.Range("B12").Value, WS.Range("C12").Value, _ WS.Range("D12").Value, WS.Range("E12").Value, WS.Range("F12").Value, _ WS.Range("G12").Value, WS.Range("H12").Value, WS.Range("A15").Value, _ WS.Range("B15").Value, WS.Range("C15").Value, WS.Range("D15").Value, _ WS.Range("E15").Value, WS.Range("F15").Value, WS.Range("G15").Value, WS.Range("H15").Value) For i = LBound(ColArr) To UBound(ColArr) If dest.Cells(Irow, ColArr(i)).Value <> cnt(i) Then dest.Cells(Irow, ColArr(i)).Value = cnt(i) End If Next i Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub وفي حدث ورقة استدعاء Private Sub Worksheet_Change(ByVal Target As Range) Dim Clé As String, cntArr As Range Set cntArr = Me.Range("A12:H12,A15:B15") If Not Intersect(Target, cntArr) Is Nothing Then Call TestUpdate End If End Sub اذا حصل تغيير - يذهب التغيير الى السجل على اساس الأسم.xlsm

العفو أخي يسعدنا أننا إستطعنا مساعدتك إليك طريقة أسرع ومختصرة Option Explicit Sub test2() Dim lastrow&, a&, i&, n&, cnt& Dim f As Worksheet, WS As Worksheet, OnRng As Variant Set WS = Sheets("الخزينه") Set f = Sheets("تحصيلات نقدية") lastrow = WS.Cells(WS.Rows.Count, "B").End(xlUp).Row a = f.Cells(f.Rows.Count, "A").End(xlUp).Row + 1 OnRng = WS.Range("B4:G" & lastrow).Value For i = 1 To UBound(OnRng, 1) cnt = Application.WorksheetFunction.CountIfs(f.Range("A2:A" & a - 1), OnRng(i, 1), _ f.Range("B2:B" & a - 1), OnRng(i, 6), _ f.Range("C2:C" & a - 1), OnRng(i, 2), _ f.Range("D2:D" & a - 1), OnRng(i, 5)) If cnt = 0 And (OnRng(i, 6) = "دفعه" Or OnRng(i, 6) = "تصفيه") Then f.Cells(a, 1).Resize(1, 4).Value = Array(OnRng(i, 1), OnRng(i, 6), OnRng(i, 2), OnRng(i, 5)) a = a + 1 n = n + 1 End If Next i MsgBox IIf(n > 0, "تم ترحيل البيانات بنجاح", "البيانات محدثة مسبقا") End Sub مشروع خزنه 1.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته جرب هل هدا ما تقصده Option Explicit Sub test() Dim LR As Long, i As Long, c As Long, R As Long Dim D As String, T As String, n As Long Dim Sh As Worksheet, WS As Worksheet Set Sh = Sheets("تحصيلات نقدية") LR = Range("b" & Rows.Count).End(xlUp).Row R = Sh.Range("a" & Rows.Count).End(xlUp).Row + 1 D = "دفعه" T = "تصفيه" For i = 4 To LR c = Application.WorksheetFunction.CountIfs(Sh.Range("a2:a" & R - 1), Range("b" & i), _ Sh.Range("b2:b" & R - 1), Range("g" & i), _ Sh.Range("c2:c" & R - 1), Range("c" & i), _ Sh.Range("d2:d" & R - 1), Range("f" & i)) If c = 0 And (Range("G" & i) = D Or Range("G" & i) = T) Then Sh.Range("a" & R).Value = Range("b" & i).Value Sh.Range("b" & R).Value = Range("g" & i).Value Sh.Range("c" & R).Value = Range("c" & i).Value Sh.Range("d" & R).Value = Range("f" & i).Value R = R + 1 n = n + 1 End If Next i If n > 0 Then MsgBox "تم ترحيل البيانات بنجاح" Else MsgBox "البيانات محدثة مسبقا" End If End Sub

ادن قم بتغيير الجزء الأخير من الكود على الشكل التالي ليتناسب مع طلبك Private Sub ComboBox1_AfterUpdate() 'Code................ ' ترتيب أبجدي Tbl = j.Keys SrtArr Tbl Me.ComboBox2.Clear Me.ComboBox2.List = Tbl End Sub '============ Sub SrtArr(a As Variant) Dim temp As Variant Dim i As Long, j As Long Dim num1 As Long, num2 As Long Dim txt1 As String, txt2 As String For i = LBound(a) To UBound(a) - 1 For j = i + 1 To UBound(a) txt1 = Trim(Split(a(i), " ")(0)) On Error Resume Next num1 = CLng(Split(a(i), " ")(1)) On Error GoTo 0 txt2 = Trim(Split(a(j), " ")(0)) On Error Resume Next num2 = CLng(Split(a(j), " ")(1)) On Error GoTo 0 If num1 > num2 Then temp = a(i) a(i) = a(j) a(j) = temp End If Next j Next i End Sub ترتيب البيانات ابجديا v3.xlsm