محمد هشام.

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

بارك الله فيك اخي @عبدالله بشير عبدالله فعلا لم انتبه لهدا

وعليكم السلام ورحمة الله تعالى وبركاته بعد إدن الإخوة الكرام اليك حلول اخرى بالمعادلات =MAX(IFERROR(VALUE(LEFT(A1:A200, LEN(A1:A200) - IF(ISNUMBER(VALUE(RIGHT(A1:A200, 1))), 0, 1))), A1:A200)) أو =MAX(LET(val,A1:A200, num, IFERROR(VALUE(LEFT(val, LEN(val) - IF(ISNUMBER(VALUE(RIGHT(val, 1))), 0, 1))), val), IF(ISNUMBER(num), num, 0))) في حالة الرغبة باستخدام الأكواد إليك الدالة التالية Function GetMaxValue(rng As Range) As Double Dim maxValue As Double, n As Double Dim Cnt As String, r As String, cell As Range c = 0 For Each cell In rng If Not IsEmpty(cell.Value) Then Cnt = cell.Value If IsNumeric(Right(Cnt, 1)) Then n = CDbl(Cnt) Else r = Left(Cnt, Len(Cnt) - 1) n = CDbl(r) End If If n > c Then c = n End If End If Next cell GetMaxValue = c End Function =GetMaxValue(A1:A200) اكبر قيمة V2.xlsb

السلام عليكم ورحمة الله تعالى وبركاته كما وضح الأستاد @أ / محمد صالح يجب عليك وضع الكود في حدث ورقة قوائم الفصول لاكن اخي @حسين النجدى الصورة تظهر مشكلة في أسماء أوراق العمل داخل مشروع VBA حيث يتم عرض الأسماء على شكل "?????" هذه المشكلة غالبا تتعلق بعدم دعم الترميز العربي بشكل صحيح داخل Excel أو محرر VBA مما يسبب ظهور رسالة الخطأ معك . تأكد من أن إعدادات اللغة في نظام التشغيل عندك على الجهاز مضبوطة للغة العربية اذهب إلى Control Panel > Clock and Region > Region ثم في تبويب Administrative اضغط على Change system locale وتأكد من ظبط اللغة العربية 1) اذا كان هذا لا يناسبك جرب الإشارة مباشرة داخل الكود إلى الأسماء الفعلية المستخدمة في المصنف الخاص بك على الشكل التالي Set wsDatabase = Worksheet____1 Set wsLists = Worksheet____3 2) بعد إذن الأستاذ محمد صالح و إثراءا للموضوع اليك حل اخر مع بعض الاظافات البسيطة لتنفيد الكود بنفس الطريقة (عند التغيير في الخلية D5) Const Classe As String = "D5" Private Sub Worksheet_Change(ByVal Target As Range) Select Case Target.Address(0, 0) Case Classe Dim clé As String Dim WS As Worksheet, dest As Worksheet Dim lastRow As Long, i As Long, n As Long, r As Long Dim Rng As Variant, a As Variant, OnRng As Variant Set WS = Worksheet____1 Set dest = Worksheet____3 clé = dest.[D5].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 Rng(1 To lastRow, 1 To 3) ReDim a(1 To lastRow, 1 To 3) For i = 1 To UBound(OnRng, 1) If OnRng(i, 2) = clé And Len(OnRng(i, 1)) > 0 Then Select Case OnRng(i, 3) Case "ذكر" n = n + 1 Rng(n, 1) = n: Rng(n, 2) = OnRng(i, 1) Rng(n, 3) = WS.Cells(i + 1, "M").Value Case "انثى" r = r + 1 a(r, 1) = r: a(r, 2) = OnRng(i, 1) a(r, 3) = WS.Cells(i + 1, "M").Value End Select End If Next i If n = 0 And r = 0 Then MsgBox "لا توجد بيانات للفصل " & clé & " على " & WS.Name, vbExclamation Else Union(dest.Range("A7:C40"), dest.Range("D7:F40")).ClearContents If n > 0 Then dest.Range("A7").Resize(n, 3).Value = Application.Index(Rng, _ Evaluate("ROW(1:" & n & ")"), Array(1, 2, 3)) End If If r > 0 Then dest.Range("D7").Resize(r, 3).Value = Application.Index(a, _ Evaluate("ROW(1:" & r & ")"), Array(1, 2, 3)) End If End If Application.ScreenUpdating = True End Select End Sub او Sub ClassData() Dim WS As Worksheet, dest As Worksheet Dim clé As String Dim lastRow As Long, i As Long, n As Long, r As Long Dim Rng As Variant, a As Variant, OnRng As Variant ' Code.............. .................... If r > 0 Then dest.Range("D7").Resize(r, 3).Value = Application.Index(a, _ Evaluate("ROW(1:" & r & ")"), Array(1, 2, 3)) End If End If Application.ScreenUpdating = True End Sub بالتوفيق ......... قوائم.xlsm

بطريقة اخرى دون الاعتماد على الارتباط التشعبي يكفي اظافة اسم أوراق العمل على العمود A وعند الظغط سيتم اظهار مربع لادخال كلمة المرور مباشرة مما يسهل على المستخدم الاشتغال على الملف دون اعادة كتابة اسم ورقة العمل عند كل محاولة دخول Lesson plan V1 Draft.xlsm

ادن جرب هدا Private Sub TextBox1_Change() Dim ws As Worksheet, rng As Range Dim cell As Range, results As Collection Dim searchKey As String, i As Long Set ws = ThisWorkbook.Sheets("HOME1") Set rng = ws.Range("C2:C" & ws.Cells(ws.Rows.Count, "C").End(xlUp).Row) Set results = New Collection ListBox1.clear searchKey = Trim(TextBox1.Text) For Each cell In rng If InStr(1, cell.value, searchKey, vbTextCompare) > 0 Then On Error Resume Next results.Add cell.value, CStr(cell.value) On Error GoTo 0 End If Next cell For i = 1 To results.Count ListBox1.AddItem results(i) Next i TextBox19 = ListBox1.ListCount If searchKey = "" Then Dim ctrl As Control For Each ctrl In Me.Controls If TypeName(ctrl) = "TextBox" Or TypeName(ctrl) = "ComboBox" Then ctrl.Text = "" End If Next ctrl TextBox19 = ListBox1.ListCount End If End Sub برنامج المعطل 2024 V5.xlsm

صراحة لم افهم طلبك اليوزرفورم يشتغل بشكل جيد ما الغرض من استبدال العناصر مادام تم تنفيد ما طلبته وزيادة

وعليكم السلام ورحمة الله تعالى وبركاته بما انك اخي ترغب بتعبئة الفاتورة عن طريق اليوزرفورم مع إمكانية البحث بالحروف الأولى او اي جزء من الإسم في عمود البيان إليك طريقة أكثر ديناميكية ربما تناسبك Dim TabBD(), OnRng(), a() Private Sub UserForm_Initialize() Dim WS As Worksheet, c As Variant Dim lastRow As Long, dict As Object Set WS = ThisWorkbook.Sheets("Sheet2") lastRow = WS.Cells(WS.Rows.Count, "C").End(xlUp).Row a = WS.Range("C2:C" & lastRow).Value OnRng = Application.Transpose(WS.Range("B2:B" & lastRow).Value) Set dict = CreateObject("Scripting.Dictionary") For Each c In OnRng If Trim(c) <> "" Then dict(c) = "" End If Next c Me.ComboBox1.List = dict.keys End Sub '============ Private Sub Button1_Click() Dim lastRow As Range If Not Intersect(ActiveCell, ThisWorkbook.Sheets("Sheet1").Range("B15:B24")) Is Nothing Then If Me.ComboBox1 <> "" And Me.ComboBox2 <> "" Then ActiveCell.Value = UCase(Me.ComboBox1) If Me.TextBox1 <> "" Then ActiveCell.Offset(, 1).Value = Me.TextBox1.Value End If Unload Me Else MsgBox "يرجى إظافة البيانات", vbInformation Exit Sub End If Else Set lastRow = ThisWorkbook.Sheets("Sheet1").Range("B15:B24").Find(What:="", LookIn:=xlValues) If Not lastRow Is Nothing Then lastRow.Value = UCase(Me.ComboBox1) If Me.TextBox1 <> "" Then lastRow.Offset(, 1).Value = Me.TextBox1.Value End If Unload Me Else MsgBox "لا توجد خلايا فارغة متاحة في الفاتورة", vbInformation Exit Sub End If End If End Sub '=============== Private Sub ComboBox1_Change() If Me.ComboBox1.ListIndex = -1 And IsError(Application.Match(Me.ComboBox1, OnRng, 0)) Then Set dict = CreateObject("Scripting.Dictionary") tmp = "*" & UCase(Me.ComboBox1) & "*" For Each c In OnRng If UCase(c) Like tmp Then dict(c) = "" Next c Me.ComboBox1.List = dict.keys Me.ComboBox1.DropDown Else Search = UCase(Me.ComboBox1) If Search = "" Then Exit Sub ligne = 0 ReDim TabBD(1 To UBound(a)) For i = LBound(a) To UBound(a) If OnRng(i) = Search Then ligne = ligne + 1 TabBD(ligne) = a(i, 1) End If Next i ReDim Preserve TabBD(1 To ligne) Me.ComboBox2.List = TabBD If Me.ComboBox2.ListCount > 0 Then Me.ComboBox2.ListIndex = 0 End If End If End Sub '============ Private Sub ComboBox2_Change() If Me.ComboBox1 <> "" Then If Me.ComboBox2.ListIndex = -1 Then Set dict = CreateObject("Scripting.Dictionary") tmp = UCase(Me.ComboBox2) & "*" For Each c In TabBD If UCase(c) Like tmp Then dict(c) = "" Next c Me.ComboBox2.List = dict.keys Me.ComboBox2.DropDown Else tmp = Application.Match(Me.ComboBox2.Value, TabBD, 0) End If End If End Sub Private Sub ComboBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean) ComboBox1.Value = "" End Sub وفي حدث Sheet1 ضع الكود التالي Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Not Intersect([B15:B24], Target) Is Nothing And Target.Count = 1 Then With UserForm2 .StartUpPosition = 0 .Left = Target.Left + 506 .Top = Target.Top + 30 - Cells(ActiveWindow.ScrollRow, 1).Top .Show End With End If End Sub فاتورة مبيعات مميزه 4.xlsm