محمد هشام.

تفضل أخي 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

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

وعليكم السلام ورحمة الله تعالى وبركاته جرب هذا Sub SaveAs_PDF() Dim NAME1 As String Dim NAME2 As String Dim NAME3 As String Dim Path As String Dim fname As String 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" MsgBox "Saved as PDF" ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Path & fname, IgnorePrintAreas:=False End Sub مع التأكد من تفعيل المراجع الأساسية على مكتبة vba مثل: Visual Basic For Applications Microsoft Excel Object Library

Function CalculateAge(xDate As Range, AgeType As String) As Variant If IsEmpty(xDate) Or Not IsDate(xDate.Value) Then CalculateAge = "" Else Select Case AgeType Case "Days" CalculateAge = Date - xDate Case "Months" CalculateAge = (Year(Date) - Year(xDate)) * 12 + (Month(Date) - Month(xDate)) Case "Years" CalculateAge = Year(Date) - Year(xDate) If Month(Date) < Month(xDate) Or (Month(Date) = Month(xDate) And Day(Date) < Day(xDate)) Then CalculateAge = CalculateAge - 1 End If Case Else CalculateAge = "" End Select End If End Function العمر بالايام =CalculateAge(A2, "Days") العمر بالشهور =CalculateAge(A2, "Months") العمر بالسنوات =CalculateAge(A2, "Years") تحديث الدالة لتشمل حساب العمر بالايام - الشهور- السنوات وكدالك (العمر بالسنوات، الأشهر، والأيام) Function CalculateAge(xDate As Range, AgeType As String) As Variant If IsEmpty(xDate) Or Not IsDate(xDate.Value) Then CalculateAge = "" Else Dim todayDate As Date todayDate = Date Select Case AgeType Case "Days" CalculateAge = todayDate - xDate.Value Case "Months" CalculateAge = (Year(todayDate) - Year(xDate.Value)) * 12 + (Month(todayDate) - Month(xDate.Value)) Case "Years" CalculateAge = Year(todayDate) - Year(xDate.Value) If Month(todayDate) < Month(xDate.Value) Or (Month(todayDate) = Month(xDate.Value) And _ Day(todayDate) < Day(xDate.Value)) Then CalculateAge = CalculateAge - 1 End If Case "Full" Dim Years As Long, Months As Long, Days As Long Years = DateDiff("yyyy", xDate.Value, todayDate) If Month(todayDate) < Month(xDate.Value) Or (Month(todayDate) = Month(xDate.Value) And _ Day(todayDate) < Day(xDate.Value)) Then Years = Years - 1 End If Months = Month(todayDate) - Month(xDate.Value) If Months < 0 Then Months = Months + 12 End If Days = Day(todayDate) - Day(xDate.Value) If Days < 0 Then Days = Day(DateSerial(Year(todayDate), Month(todayDate), 0)) + Days End If CalculateAge = Years & " years, " & Months & " months, " & Days & " days" Case Else CalculateAge = "" End Select End If End Function لحساب العمر بالسنوات، الأشهر، والأيام =CalculateAge(A2, "Full") '============ بالمعادلات============== العمر بالسنوات =IF(A2="", "", DATEDIF(A2, TODAY(), "Y")) العمر بالسنوات والأشهر =IF(A2="", "", DATEDIF(A2, TODAY(), "Y") & " Years, " & DATEDIF(A2, TODAY(), "YM") & " Months") العمر بالسنوات والأشهر والأيام =IF(A2="", "", DATEDIF(A2, TODAY(), "Y") & " Years, " & DATEDIF(A2, TODAY(), "YM") & " Months, " & DATEDIF(A2, TODAY(), "MD") & " Days") احتساب عدد الايام او الشهور او السنوات من تاريخ معين.rar

وعليكم السلام ورحمة الله تعالى وبركاته جرب هذا مع تغيير أسماء الأعمدة بما يناسبك =SUMPRODUCT(--(B2:B12<>"")*(B2:B12<>"غ")*(B2:B12<>"غياب")*(B2:B12<>"تخلف")) المصنف1.xlsx

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا هل يشتغل معك عند محاولة الدخول لورقة 1 TEST.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Sub deletX() Dim x As String, wordn As Long Dim ce As Range, rng As Range, n As Boolean 'نطاق ثابت ' Set rng = Range("C4:R15") ' قم بتعديله بما يناسبك ' تحديد النطاق يدويًا On Error Resume Next Set rng = Application.InputBox("Select the range you want to search:", Type:=8) On Error GoTo 0 If rng Is Nothing Then Exit Sub Do x = InputBox("What is the word whose cells you want to delete?") If x = "" Then If MsgBox("The input box is empty. Do you want to try again?", _ vbYesNo + vbExclamation, "Empty Input") = vbNo Then Exit Sub End If Loop While x = "" If MsgBox("Are you sure you want to delete cells containing the word: " & x & _ "?", vbYesNo + vbQuestion, "Confirm Deletion") = vbNo Then Exit Sub n = False For Each ce In rng If Not IsEmpty(ce.Value) And Len(ce.Value) >= Len(x) Then wordn = InStr(1, LCase(ce.Value), LCase(x)) If wordn > 0 Then ce.ClearContents n = True End If End If Next ce If n Then MsgBox "تم الحذف بنجاح", vbInformation Else MsgBox "لم يتم العثور على الكلمة: " & x, vbExclamation End If End Sub Delete_Fixed_Cells.xls

غريب ممكن ترفع لنا الملف التي تظهر معك به المشكلة

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

وعليكم السلام ورحمة الله تعالى وبركاته اظن ان المشكلة في عدم تواجد الورقة المسمات (التفريغ) على المصنف لديك والتي بدورها تتضمن النطاق AAAA لتعبئة كومبوبوكس1 والنطاق AAA لتعبئة كومبوبوكس2 ماكرو 2024.xls

جرب هدا في Module ضع الدالة التالية Function CalculateAge(xDate As Range, Age As Boolean) As Variant If IsEmpty(xDate) Or Not IsDate(xDate.Value) Then CalculateAge = "" Else If Age Then CalculateAge = Date - xDate Else CalculateAge = (Year(Date) - Year(xDate)) * 12 + (Month(Date) - Month(xDate)) End If End If End Function ضع تاريخ الميلاد في خلية معينة مثلا A2 حساب العمر بالأيام =CalculateAge(A2, TRUE) العمر بالشهور =CalculateAge(A2, FALSE) بالمعادلات العمر بالأيام =IF(A2="", "", TODAY()-A2) العمر بالشهور =IF(A2="", "", (YEAR(TODAY()) - YEAR(A2)) * 12 + (MONTH(TODAY()) - MONTH(A2))) CalculateAge.xlsb

السلام عليكم ورحمة الله تعالى وبركاته الكود المقترح من الأستاد @حسونة حسين يشتغل بشكل جيد وينفد المطلوب مجرد اقتراح حاول وضع السطر التالي في حدث ورقة مبيعات الشهر مع ادخال بعض البيانات على اوراق العمل Private Sub Worksheet_Activate() Test End Sub في حالة الرغبة باستخدام الاكواد بدل الصيغ الموجودة على جميع اوراق العملاء ضع الكود التالي في حدث ThisWorkbook Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) Dim lr As Long, n As Double, i As Long Dim totalD As Double, totalE As Double Dim WS As Worksheet: Set WS = Sh If InStr(1, WS.name, "عميل") = 0 Then Exit Sub If Not Intersect(Target, WS.Columns("D:E")) Is Nothing Or Not Intersect(Target, WS.Range("G6")) Is Nothing Then lr = Application.WorksheetFunction.Min(42, _ Application.WorksheetFunction.Max(WS.Cells(WS.Rows.Count, "D").End(xlUp).Row, _ WS.Cells(WS.Rows.Count, "E").End(xlUp).Row)) WS.Range("F9:F42").ClearContents n = WS.Range("G6").Value For i = 9 To lr If WS.Cells(i, "D").Value > 0 Or WS.Cells(i, "E").Value > 0 Then n = n + WS.Cells(i, "D").Value - WS.Cells(i, "E").Value WS.Cells(i, "F").Value = n End If Next i totalD = Application.WorksheetFunction.Sum(WS.Range("D9:D42")) totalE = Application.WorksheetFunction.Sum(WS.Range("E9:E42")) WS.Range("C44").Value = totalD WS.Range("C45").Value = totalE WS.Range("C46").Value = WS.Range("G6").Value + (totalD - totalE) End If End Sub واظافة الاسطر التالية اسفل كود الاستاد حسونة لحساب مجموع الاعمدة على ورقة مبيعات الشهر Dim totals(1 To 3) As Double Sh.[A1].Value = "قائمة تعاملات عملاء 6 أكتوبر حتى يوم: " & Format(Date, "dd/mm/yyyy") For i = 1 To 3 totals(i) = Application.WorksheetFunction.Sum(Sh.Range(Cells(3, i + 2), Cells(152, i + 2))) Sh.Cells(153, i + 2).Value = totals(i) Next i Customers-Project-02.xlsb

حدد الخلية التي تحتوي على المعادلة (E3) توجه إلى علامة التبويب (Home) في شريط الأدوات في جزء التنسيق (Number Format) تحقق من نوع التنسيق المستخدم ستجده مضبوطا على (Text) قم بتغييره الى (General) عدم ظهور نتيجة المعادلة_٠٨٢٤١٠.xlsx تبسيط المعادلة =IF(AND(J3<>"", I3<>""), WORKDAY.INTL(I3, J3, 15), "")

وعليكم السلام ورحمة الله تعالى وبركاته ادا كنت تقصد انك ترغب بجمع القيمة الإجمالية في العمود "K" التي تتوافق مع القيم الفريدة في العمود "C" إليك اقتراح اخر بطريقة مختصرة Sub test1() Dim SumCel As Range Dim f As Worksheet, Irow As Long, r As Long Dim dict As Object, n As Double, tmp As String Set f = ThisWorkbook.Sheets("Sheet1") Irow = f.Cells(f.Rows.Count, "C").End(xlUp).Row Set SumCel = f.[O5] Set dict = CreateObject("Scripting.Dictionary") For r = Irow To 4 Step -1 tmp = f.Cells(r, "C").Value If Not dict.exists(tmp) Then dict.Add tmp, f.Cells(r, "K").Value End If Next r n = Application.Sum(dict.Items): SumCel.Value = n End Sub تجارب اجمالى العهدة V1.xlsb

بارك الله فيكم جميعا كما تم التنويه سابقا لإثراء الموضوع لا أقل ولا أكثر رغم ان التعليق الأخير للأخ @حسين النجدى ( مثلا 70 تلاميذ بيكتبهم تحت المفروض يحتويهم ) هو كدالك غير مفهوم بالنسبة لي يمكننا تعديل الكود المقترح سابقا ليقوم بنسخ الذكور فى صف والاناث فى صف مع دمج الكود في حدث الشيت ليتم تنفيده عند التغيير سواءا في الجدول 1 أو 2 ونسخ البيانات للمكان المناسب Const Classe As String = "D5" Sub FilterClassData() Dim clé As String, OnRng As Variant Dim WS As Worksheet, dest As Worksheet Dim lastRow As Long, i As Long, r As Long Dim male As Long, female As Long Set WS = ThisWorkbook.Sheets("قاعدة البيانات") Set dest = ThisWorkbook.Sheets("قوائم الفصول") clé = dest.Range(Classe).Value If clé = "" Then Exit Sub Application.ScreenUpdating = False If WS.AutoFilterMode Then WS.AutoFilterMode = False lastRow = WS.Cells(WS.Rows.Count, "B").End(xlUp).Row OnRng = WS.Range("B2:D" & lastRow).Value ReDim a(1 To lastRow, 1 To 3) r = 0: male = 0: female = 0 For i = 1 To UBound(OnRng, 1) If OnRng(i, 2) = clé And Len(OnRng(i, 1)) > 0 Then r = r + 1 a(r, 1) = r a(r, 2) = OnRng(i, 1) a(r, 3) = WS.Cells(i + 1, "M").Value Select Case OnRng(i, 3) Case "ذكر" male = male + 1 Case "انثى" female = female + 1 End Select End If Next i If r = 0 Then MsgBox "لا توجد بيانات للفصل " & clé & " على " & WS.Name, vbExclamation Else Union(dest.Range("A7:C40"), dest.Range("D7:F40")).ClearContents If r <= 34 Then dest.Range("A7").Resize(r, 3).Value = Application.Index(a, _ Evaluate("ROW(1:" & r & ")"), Array(1, 2, 3)) Else dest.Range("A7").Resize(34, 3).Value = Application.Index(a, _ Evaluate("ROW(1:34)"), Array(1, 2, 3)) dest.Range("D7").Resize(r - 34, 3).Value = Application.Index(a, _ Evaluate("ROW(35:" & r & ")"), Array(1, 2, 3)) End If MsgBox "عدد الذكور: " & male & vbCrLf & "عدد الإناث: " & female, vbInformation End If Application.ScreenUpdating = True End Sub '( D5 أو D87 )تنفيد الكود عند التغيير في خلايا إسم الفصل Const Classe1 As String = "D5" Const Classe2 As String = "D87" Private Sub Worksheet_Change(ByVal Target As Range) Dim WS As Worksheet, dest As Worksheet, destRng As Range, MaxRows As Long, _ lastRow As Long, i As Long, r As Long, OnRng As Variant, a As Variant, clé As String Select Case Target.Address(0, 0) Case Classe1, Classe2 Set WS = ThisWorkbook.Sheets("قاعدة البيانات") Set dest = ThisWorkbook.Sheets("قوائم الفصول") If Target.Address(0, 0) = Classe1 Then clé = dest.Range(Classe1).Value Set destRng = dest.Range("A7") MaxRows = 40 ElseIf Target.Address(0, 0) = Classe2 Then clé = dest.Range(Classe2).Value Set destRng = dest.Range("A89") MaxRows = 122 End If If clé = "" Then Exit Sub Application.ScreenUpdating = False If WS.AutoFilterMode Then WS.AutoFilterMode = False lastRow = WS.Cells(WS.Rows.Count, "B").End(xlUp).Row OnRng = WS.Range("B2:D" & lastRow).Value ReDim a(1 To lastRow, 1 To 3) r = 0 For i = 1 To UBound(OnRng, 1) If OnRng(i, 2) = clé And Len(OnRng(i, 1)) > 0 Then r = r + 1 a(r, 1) = r a(r, 2) = OnRng(i, 1) a(r, 3) = WS.Cells(i + 1, "M").Value End If Next i If r = 0 Then MsgBox "لا توجد بيانات للفصل " & clé & " على " & WS.Name, vbExclamation Else If Target.Address(0, 0) = Classe1 Then Union(dest.Range("A7:C40"), dest.Range("D7:F40")).ClearContents ElseIf Target.Address(0, 0) = Classe2 Then Union(dest.Range("A89:C122"), dest.Range("D89:F122")).ClearContents End If If r <= 34 Then destRng.Resize(r, 3).Value = Application.Index(a, _ Evaluate("ROW(1:" & r & ")"), Array(1, 2, 3)) Else destRng.Resize(34, 3).Value = Application.Index(a, _ Evaluate("ROW(1:34)"), Array(1, 2, 3)) dest.Range("D" & destRng.Row).Resize(r - 34, 3).Value = Application.Index(a, _ Evaluate("ROW(35:" & r & ")"), Array(1, 2, 3)) End If End If End Select Application.ScreenUpdating = True End Sub بيانات الفصول.xlsb