نجوم المشاركات

السلام عليكم في احد مشاريعي ، جابوا لي قائمة اكسل فيها تواريخ مكتوبة بكل ما لذ وطاب من الطرق ، مثل: 30/11/2009 ، 2012-06-25 ، 21/6/2015م ، " 9/1/2014" ، 30\11\2009 ، 5/1999/26 ، 25/1999/6 ، 5/1994/ 26 ، وحتى بعضها بالارقام الهندية ، فعملت الدالة التالية ، والتي ترسل لها التاريخ المطلوب تعديله ، والدالة تصلح التاريخ وترجعه. وستلاحظون اني استخدمت الدالة DateSerial ، حتى اعطي اليوم والشهر والسنة بياناتهم يدويا ، بدلا عن استعمال CDate . هذه هي الدالة: Function Date_Rectified(D As String) As Date On Error Resume Next Dim x() As String Dim P1 As String, P2 As String, P3 As String D = Trim(D) D = Replace(D, "(", "") D = Replace(D, ")", "") D = Replace(D, " ", "") D = Replace(D, " ", "") D = Replace(D, " ", "") D = Replace(D, " ", "") D = Replace(D, "*", "") D = Replace(D, "م", "") D = Replace(D, ChrW(1632), "0") 'الرقم الهندي صفر D = Replace(D, ChrW(1633), "1") D = Replace(D, ChrW(1634), "2") D = Replace(D, ChrW(1635), "3") D = Replace(D, ChrW(1636), "4") D = Replace(D, ChrW(1637), "5") D = Replace(D, ChrW(1638), "6") D = Replace(D, ChrW(1639), "7") D = Replace(D, ChrW(1640), "8") D = Replace(D, ChrW(1641), "9") D = Replace(D, "!", "-") D = Replace(D, "/", "-") D = Replace(D, "//", "-") D = Replace(D, "\", "-") D = Replace(D, ".", "-") D = Replace(D, "_", "-") D = Replace(D, "|", "-") D = Replace(D, ",", "-") D = Replace(D, Chr(34), "") If Len(D) = 4 Then 'starts with year, but its 4 digits only:1999 'convert to 1-1-1999 OR EMPTY Date_Rectified = DateSerial(D, 1, 1) Exit Function End If If D = "5/1994/ 26" Then Debug.Print D End If x = Split(D, "-") P1 = x(0): P2 = x(1): P3 = x(2) If Len(P1) = 4 And Len(P2) <> 0 Then 'starts with year, and month exist: 1999-1-2 Date_Rectified = DateSerial(P1, P2, P3) ElseIf Len(P3) = 4 And Len(P2) <> 0 Then 'ends with year, and month exist: 2-1-1999 Date_Rectified = DateSerial(P3, P2, P1) ElseIf Len(P2) = 4 And Len(P1) <= 12 Then 'year in the middle, day and month exist: 5/1999/26 Date_Rectified = DateSerial(P2, P1, P3) ElseIf Len(P2) = 4 And Len(P1) > 12 Then 'year in the middle, day and month exist: 25/1999/6 Date_Rectified = DateSerial(P2, P3, P1) Else 'otherwise Date_Rectified = Null End If End Function

ومشاركة مع أستاذي الجليل @jjafferr Me.YourTextBox = UCase(Me.YourTextBox)

وعليكم السلام في احد مشاريعي ، جابوا لي قائمة اكسل فيها تواريخ مكتوبة بكل ما لذ وطاب من الطرق ، مثل: 30/11/2009 ، 2012-06-25 ، 21/6/2015م ، " 9/1/2014" ، 30\11\2009 ، 5/1999/26 ، 25/1999/6 ، 5/1994/ 26 ، وحتى بعضها بالارقام الهندية ، فعملت الدالة التالية ، والتي ترسل لها التاريخ المطلوب تعديله ، والدالة تصلح التاريخ وترجعه. ومنها تقدر تحصل على السنة 🙂 هذه هي الدالة: Function Date_Rectified(D As String) As Date On Error Resume Next Dim x() As String Dim P1 As String, P2 As String, P3 As String D = Trim(D) D = Replace(D, "(", "") D = Replace(D, ")", "") D = Replace(D, " ", "") D = Replace(D, " ", "") D = Replace(D, " ", "") D = Replace(D, " ", "") D = Replace(D, "*", "") D = Replace(D, "م", "") D = Replace(D, ChrW(1632), "0") 'الرقم الهندي صفر D = Replace(D, ChrW(1633), "1") D = Replace(D, ChrW(1634), "2") D = Replace(D, ChrW(1635), "3") D = Replace(D, ChrW(1636), "4") D = Replace(D, ChrW(1637), "5") D = Replace(D, ChrW(1638), "6") D = Replace(D, ChrW(1639), "7") D = Replace(D, ChrW(1640), "8") D = Replace(D, ChrW(1641), "9") D = Replace(D, "!", "-") D = Replace(D, "/", "-") D = Replace(D, "//", "-") D = Replace(D, "\", "-") D = Replace(D, ".", "-") D = Replace(D, "_", "-") D = Replace(D, "|", "-") D = Replace(D, ",", "-") D = Replace(D, Chr(34), "") If Len(D) = 4 Then 'starts with year, but its 4 digits only:1999 'convert to 1-1-1999 OR EMPTY Date_Rectified = DateSerial(D, 1, 1) Exit Function End If If D = "5/1994/ 26" Then Debug.Print D End If x = Split(D, "-") P1 = x(0): P2 = x(1): P3 = x(2) If Len(P1) = 4 And Len(P2) <> 0 Then 'starts with year, and month exist: 1999-1-2 Date_Rectified = DateSerial(P1, P2, P3) ElseIf Len(P3) = 4 And Len(P2) <> 0 Then 'ends with year, and month exist: 2-1-1999 Date_Rectified = DateSerial(P3, P2, P1) ElseIf Len(P2) = 4 And Len(P1) <= 12 Then 'year in the middle, day and month exist: 5/1999/26 Date_Rectified = DateSerial(P2, P1, P3) ElseIf Len(P2) = 4 And Len(P1) > 12 Then 'year in the middle, day and month exist: 25/1999/6 Date_Rectified = DateSerial(P2, P3, P1) Else 'otherwise Date_Rectified = Null End If End Function

وعليكم السلام اذا الحقل: me.abc="i am small letters" لتكبير الحروف me.abc= Format(me.abc, ">")

بالإضافة لطريقة المهندس @محمد احمد لطفى جرب هذه الطريقة أيضا 🙂 : If IsDate(Me.datex) Then Me.datex2 = Year(CDate(Me.datex)) End If test8102024.rar

@محمد هشام. جزاك الله خيراً فعلاً تنسيق الخلية كان "نص" ولكن الإشكالية كانت أنني إرتكبت خطأ في كتابة الدالة وإنتبهت لها أثناء تعديل تنسيق الخلية. بوركت ...

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

شكرا انا خلاص قدرت احلها وبعدين انا سايباك للتجيله☺️

التواصل مع صاحب الكود لتعديله ليتوافق مع نسخ 64 بت او تغيير نظام التشغيل ل 32بت

ماشاء الله تبارك الله .. لك بصمة في كل مجال 🙂

يا سلام عليك الله يحفظك .. نحن بحاجة الى مواضيع متخصصة تضاف الى المكتبة يتم فيها تجميع مثل هذه الروائع بعناوين حسب كل فن

عدلت العنوان من اجل يكون قريب للباحث وهذه طريقة اخرى ايضا Me.datex2 = Format(CDate(datex), "yyyy")

تفضل بالتوفيق test8102024.rar

الحمد لله والف شكر على هذه الكلمات الطيبات

تحياتي للأستاذ / أمير حل رائع . إضافة بسيطة و هو كود لاستحراج أكبر قيمة مع النص الموجود بجانب الرقم Function LargestValueWithOriginalText(rng As Range) As String Dim cell As Range Dim matches As Object Dim maxNum As Double Dim num As Double Dim regex As Object Dim resultText As String ' Create a regular expression object Set regex = CreateObject("VBScript.RegExp") regex.Pattern = "\d+\.?\d*" ' Pattern to match numbers (including decimals) regex.Global = True maxNum = -1 ' Initialize maxNum to a low value resultText = "No numeric values found." ' Default message ' Loop through each cell in the specified range For Each cell In rng If Not IsEmpty(cell.Value) Then ' Find all matches in the cell Set matches = regex.Execute(cell.Value) ' Loop through all found matches For Each Match In matches num = CDbl(Match.Value) ' Convert match to a number If num > maxNum Then maxNum = num ' Update maxNum if the current number is larger resultText = cell.Value ' Store the text of the cell with the largest number End If Next Match End If Next cell ' If a number was found, return the original text If maxNum > -1 Then LargestValueWithOriginalText = resultText Else LargestValueWithOriginalText = resultText End If End Function اكبر قيمه (2).xlsm

عشان تقدر تطبق المطلوب كان لابد من عمد كود برمجة فيه داله اسمها MaxNumber تعمل المطلوب وبشكل مختصر هذا كود البرمجة: Function MaxNumber(rng As Range) As Double Dim cell As Range Dim matches As Object Dim largest As Double Dim regex As Object Set regex = CreateObject("VBScript.RegExp") regex.Global = True regex.IgnoreCase = True regex.Pattern = "\d+(\.\d+)?" largest = -1 For Each cell In rng If Not IsEmpty(cell.Value) Then Set matches = regex.Execute(cell.Value) If matches.Count > 0 Then Dim match As Variant For Each match In matches If CDbl(match.Value) > largest Then largest = CDbl(match.Value) End If Next match End If End If Next cell MaxNumber = largest End Function بعد كده اختار أي عمود تحتاجه عادي جدا زي ما بتعمل أي معادلة وهذه المعادلة كده بتكون : =MaxNumber(A1:A100) تحياتي 🙂 اكبر قيمه.xlsm

نعم ضع المعايير التي تريدها في الدالة .

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

لا اعلم مادا تقصد هل كيفية ادراج الكود او كيفية تطبيقه على ملفات اخرى الاولى لايمكنني شرحها يمكنك البحث عنها ستجدها صوة وصورة اما الاحتمال الثاني وهو الارجح على ما اعتقد لكي تطبق الكود على ملفات اخرى لابد ان تفهمه اولا لتتمكن من تعديله بما يناسبك سأقوم بمحاولة اظافة بعض التعليقات المهمة للتوضيح Sub Collection_of_books_Sheet1() '****"RS_ST_196"' هذا الماكرو يقوم بتجميع أسماء الطلاب والكتب من ورقة ' ويقوم بنسخها إلى ورقة1 مع حساب عدد الكتب لكل طالب Dim WS As Worksheet, dest As Worksheet Dim lastRow As Long, i As Long Dim studentName As String, bookName As String, n As String Dim bookNumber As Variant, row As Range, lr As Long Dim startRow As Long, ling As Long, bCount As Integer Dim rngCell As Range Application.ScreenUpdating = False '***** تحديد أوراق العمل Set WS = ThisWorkbook.Sheets("RS_ST_196") Set dest = ThisWorkbook.Sheets("Sheet1") '******** "RS_ST_196" ,ورقة ' تحديد آخر صف في العمود AK lastRow = WS.Cells(WS.Rows.Count, "AK").End(xlUp).row With dest.Range("A2:C" & dest.Cells(dest.Rows.Count, "A").End(xlUp).row) .ClearContents ' مسح جميع البيانات في النطاق .ClearFormats ' مسح جميع التنسيقات في النطاق End With ling = 2 ' بدء الكتابة من الصف 2 في ورقة "Sheet1" ' حلقة لتمرير جميع الصفوف في ورقة المصدر من الصف 18 إلى آخر صف مستخدم For i = 18 To lastRow ' التحقق مما إذا كان الصف مخفيًا (إذا لم يكن مخفيًا، يتم معالجة الصف) If Not WS.Rows(i).Hidden Then ' الحصول على اسم الطالب من العمود "AK" studentName = WS.Cells(i, "AK").Value ' التحقق مما إذا كان اسم الطالب يبدأ بـ "اسم الطالب: " If InStr(studentName, "اسم الطالب: ") = 1 Then ' إزالة "اسم الطالب: " من بداية النص للحصول على الاسم الفعلي للطالب studentName = Trim(Mid(studentName, Len("اسم الطالب: ") + 1)) n = "" ' لتجميع أسماء الكتب bCount = 0 ' عداد للكتب startRow = i + 2 ' البدء من الصف الذي يليه للتحقق من الكتب ' حلقة لتمرير جميع الكتب المرتبطة بالطالب Do While WS.Cells(startRow, "AB").Value <> "" bookName = WS.Cells(startRow, "AB").Value bookNumber = WS.Cells(startRow, "AN").Value '(عمود التسلسل م) التأكد من أن الكتاب ليس مجرد عنوان عمود وأن رقم الكتاب غير فارغ If WS.Cells(startRow, "AB").Value <> "اسم المقرر" And Not IsEmpty(bookNumber) Then ' تجميع أسماء الكتب في متغير n If n = "" Then n = bookName Else n = n & " + " & bookName End If bCount = bCount + 1 ' زيادة عدد الكتب لكل طالب End If startRow = startRow + 1 ' الانتقال إلى الصف التالي Loop '** نسخ النتائج ' كتابة اسم الطالب، أسماء الكتب المجتمعة، وعدد الكتب في ورقة الوجهة dest.Cells(ling, "A").Value = studentName ' اسم الطالب dest.Cells(ling, "B").Value = n ' أسماء الكتب dest.Cells(ling, "C").Value = bCount ' عدد الكتب ling = ling + 1 ' الانتقال إلى الصف التالي لكتابة بيانات الطالب التالي End If End If Next i '** تحديد آخر صف مستخدم في الاعمدة A:C "Sheet1" lr = dest.Range("A:C").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).row Set rngCell = dest.Range("A2:C" & lr) '** تنسيق الخلايا في النطاق المحدد With rngCell .Font.Bold = True ' تنسيق الخط .MergeCells = False ' التأكد من عدم دمج الخلايا .HorizontalAlignment = xlCenter ' ضبط المحاذاة الأفقية إلى الوسط .VerticalAlignment = xlCenter ' ضبط المحاذاة الرأسية إلى الوسط .WrapText = True ' تفعيل التفاف النص ' ضبط ارتفاع الصفوف إلى 35 For Each row In .Rows row.RowHeight = 35 Next row End With '** إضافة حدود للخلايا في النطاق For Each c In rngCell.Rows If WorksheetFunction.CountA(c) > 0 Then c.Borders.LineStyle = xlContinuous Next Application.ScreenUpdating = True MsgBox "تم تجميع أسماء الطلاب والكتب بنجاح", vbInformation End Sub

Try this File Mhoud_1980.xlsx

وبعدين دى مقابله . مش كفايه بقالى اكتر من شهرين مش بسأل ولا بدخل اصلا