محمد هشام.

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

ليس هناك مستحيل اخي @عبد الرحمن أشرف يمكننا إظافة دالة جديدة مع الحفاظ على الأولى لتتمكن من إختيار ما يناسبك الدالة الجديدة مع التفقيط 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

هل المطلوب تحديث البيانات عند التغيير في الخلايا ذات اللون الأصفر أو الأزرق ممكن توضح أكثر

تفضل اخي الكريم جرب هدا Sub Find_MissingNumbers() Dim WS 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 Set WS = Sheets("Sheet1") 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 On Error Resume Next 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 On Error GoTo 0 ling = 3 For Each code In tmp.Keys 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 End If Next j Next code Application.ScreenUpdating = True End Sub في حالة الرغبة بالحصول على رسالة تعرض "كود الصنف" وعدد "الأرقام المفقودة" لكل صنف بعد تنفيد الكود قم بتعديل الجزء الأخير من الكود كالتالي ling = 3 Dim msg As String, KyCount As Long msg = ": ملخص الأرقام المفقودة" & vbCrLf & vbCrLf 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 msg = msg & "كود الصنف: " & code & " - عدد الأرقام المفقودة: " & KyCount & vbCrLf Next code Application.ScreenUpdating = True MsgBox msg, vbInformation, "نتيجة الأرقام المفقودة" End Sub الأرقام الناقصة v1.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته بعد إدن الاستاد @عبدالله بشير عبدالله اليك حل اخر Option Compare Text Option Explicit Dim f As Worksheet Private Sub UserForm_Initialize() Set f = ThisWorkbook.Sheets("Sheet3") Dim j As Object, OneRng As Variant, i As Long, Tbl As Variant Set j = CreateObject("Scripting.Dictionary") OneRng = f.Range("D2:D" & f.Cells(f.Rows.Count, "D").End(xlUp).Row).Value ' تعبئة كومبوبوكس 1 بالقيم غير الفارغة والغير مكررة For i = LBound(OneRng, 1) To UBound(OneRng, 1) If OneRng(i, 1) <> "" Then j(OneRng(i, 1)) = "" Next i ' ترتيب أبجدي Tbl = j.Keys SrtArr Tbl, LBound(Tbl), UBound(Tbl) Me.ComboBox1.List = Tbl End Sub Private Sub ComboBox1_AfterUpdate() If f Is Nothing Then Set f = ThisWorkbook.Sheets("Sheet3") Dim j As Object, OneRng As Variant, i As Long, Tbl As Variant Set j = CreateObject("Scripting.Dictionary") OneRng = f.Range("D2:D" & f.Cells(f.Rows.Count, "D").End(xlUp).Row).Value ' تعبئة كومبوبوكس 2 بالقيم غير الفارغة والغير مكررة وأنها لا تطابق قيمة كومبوبوكس 1 For i = LBound(OneRng, 1) To UBound(OneRng, 1) If (OneRng(i, 1) <> "") And (CStr(OneRng(i, 1)) <> Me.ComboBox1.Value) Then j(OneRng(i, 1)) = "" Next i ' ترتيب أبجدي Tbl = j.Keys SrtArr Tbl, LBound(Tbl), UBound(Tbl) Me.ComboBox2.Clear Me.ComboBox2.List = Tbl End Sub Sub SrtArr(a As Variant, gauc As Long, droi As Long) Dim ref As Variant, temp As Variant Dim g As Long, D As Long ref = a((gauc + droi) \ 2) g = gauc: D = droi Do Do While a(g) < ref: g = g + 1: Loop Do While ref < a(D): D = D - 1: Loop If g <= D Then temp = a(g): a(g) = a(D): a(D) = temp g = g + 1: D = D - 1 End If Loop While g <= D If g < droi Then SrtArr a, g, droi If gauc < D Then SrtArr a, gauc, D End Sub ترتيب البيانات ابجديا v2.xlsm

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

Sub SaveAs_PDF() Dim NAME1 As String, NAME2 As String, NAME3 As String Dim Path As String, fname As String, FullPath As String Dim response As VbMsgBoxResult NAME1 = Range("B2").Value NAME2 = Range("B3").Value NAME3 = Range("B4").Value Path = "D:\PDF\" If Dir(Path, vbDirectory) = "" Then MkDir Path End If fname = NAME1 & " - " & NAME2 & " - " & NAME3 & ".pdf" FullPath = Path & fname If Dir(FullPath) <> "" Then response = MsgBox("الملف موجود بالفعل هل تريد استبداله؟", vbYesNo + vbQuestion, "تأكيد") If response = vbNo Then Exit Sub End If End If ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=FullPath, IgnorePrintAreas:=False MsgBox "Saved As PDF " End Sub TEST SAVE PDF.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته بعد معاينة النتائج على الملف المرفق لاحظت انك ترغب بحساب الفرق بين التواريخ بطرق مختلفة خاصة طريقة حساب عدد الشهور لهدا سنقوم بدمج الدوال الخاصة بك في دالة واحدة مع بعض التعديلات للحصول على نفس النتائج الموجودة على عمود k CalcAge تحسب الفرق بين تاريخين (vDate1 و vDate2) بطريقة تقليدية CalcAgey2 تستخدم DateDiff Option Explicit Dim Cnt As Boolean Function CalcAge(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 CalcAge = "" Exit Function End If If Not IsDate(vDate1) Or Not IsDate(vDate2) Then CalcAge = CVErr(xlErrValue) Exit Function End If If vDate2 < vDate1 Then If Not Cnt Then MsgBox "التاريخ الثاني يجب أن يكون أكبر من الأول" Cnt = True End If CalcAge = CVErr(xlErrValue) Exit Function End If Cnt = False ' حساب الفرق في السنوات والأشهر والأيام 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" CalcAge = vDays Case "Months" CalcAge = vMonths Case "Years" CalcAge = vYears Case "Days and Months" CalcAge = vDays & " Days and " & vMonths & " Months" Case "Years and Months" CalcAge = vYears & " Years and " & vMonths & " Months" Case "Total" CalcAge = vDays & ", " & vMonths & ", " & vYears Case Else CalcAge = "صيغة الدالة غير معروفة" End Select End Function Function CalcAgey2(vDate1 As Variant, vDate2 As Variant, ByVal resultType As String) As Variant If IsEmpty(vDate1) Or IsEmpty(vDate2) Then CalcAgey2 = "" Exit Function End If If Not IsDate(vDate1) Or Not IsDate(vDate2) Then CalcAgey2 = CVErr(xlErrValue) Exit Function End If ' حساب الفرق في الأشهر Dim totalMonths As Integer totalMonths = DateDiff("m", vDate1, vDate2) Dim vDays As Integer vDays = DateDiff("d", DateAdd("m", totalMonths, vDate1), vDate2) If vDays < 0 Then totalMonths = totalMonths - 1 vDays = DateDiff("d", DateAdd("m", totalMonths, vDate1), vDate2) End If Dim vYears As Integer vYears = totalMonths \ 12 Dim vMonths As Integer vMonths = totalMonths Mod 12 Select Case resultType Case "Years" CalcAgey2 = vYears Case "Months" CalcAgey2 = totalMonths Case "Years and Months" CalcAgey2 = vYears & " Years and " & vMonths & " Months" Case "Days" Dim totalDays As Integer totalDays = DateDiff("d", vDate1, vDate2) CalcAgey2 = totalDays Case "Months and Days" CalcAgey2 = totalMonths & " Months and " & vDays & " Days" Case "Total" CalcAgey2 = vDays & ", " & vMonths & ", " & vYears Case Else CalcAgey2 = CVErr(xlErrValue) End Select End Function عدد الأيام =CalcAge(A3, B3, "Days") عدد الشهور =CalcAge(A3, B3, "Months") عدد السنوات =CalcAge(A3, B3, "Years") عدد الشهور الطريقة 2 =CalcAgey2(A3, B3, "Months") حساب السنوات والشهور =CalcAge(A3, B3, "Years and Months") حساب الايام والشهور =CalcAge(A3, B3, "Days and Months") حساب الفرق بين تاريخين v1.xlsm