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

وعليكم السلام ورحمة الله تعالى وبركاته ادا كنت تقصد انك ترغب بجمع القيمة الإجمالية في العمود "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

ناسف ع التاخير غير المقصود ضغط العمل نسال الله دوام التوفيق و السداد للجميع العمل سيكون مقسم الي جزئين الجزاء الاول :- تصدير فاتوره المبيعات , مردوداتها الي ملف xml الحاله :- قريبا جدا بيكون جاهز الجزاء الثاني :- و هو الاهم و الاصعب ربط الحل التقني مع هيئه الزكاه و الدخل الحاله :- جاهز تنويه :- ممكن اي احد شغال ع vb.net او c# او اي لغه برجمه ياخد طريقه العمل ويطبقها بلغه البرمجه الخاصه بيه و هيشتغل معاه ان شاء الله رابط الملفات المستخدمه للعمل ملف الاكسس + البرامج المساعده https://drive.google.com/file/d/1vrIMbKFfU6_HgWipo3L8CLAOGwjvdTvj/view?usp=drive_link رابط ملف الاكسس فقط https://drive.google.com/file/d/1YY5an9X-NYjAx2ZSL6ipr_dQcihcLrCD/view?usp=drive_link رابط الشروحات (الموضوع طويل وفيه تفاصيل كثيره وحاولت ان اختصر قدر المستطاع ) للتواصل :- ايميل :- act32add.nm@gmail.com واتساب :- 00966597465617

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

وعليكم السلام ورحمة الله وبركاته جرب الملف الكود Sub CalculateNetValues() Dim ws As Worksheet Dim lastRow As Long Dim i As Long Dim dict As Object Dim key As Variant Dim totalValue As Double Dim expenseValue As Double Dim netValue As Double Set ws = ThisWorkbook.Sheets("Sheet1") lastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row Set dict = CreateObject("Scripting.Dictionary") For i = 4 To lastRow If Not dict.exists(ws.Cells(i, "C").Value) Then dict.Add ws.Cells(i, "C").Value, ws.Cells(i, "D").Value Else dict(ws.Cells(i, "C").Value) = dict(ws.Cells(i, "C").Value) + ws.Cells(i, "D").Value End If Next i For i = 4 To lastRow If dict.exists(ws.Cells(i, "C").Value) Then If IsNumeric(ws.Cells(i, "J").Value) Then dict(ws.Cells(i, "C").Value) = dict(ws.Cells(i, "C").Value) - ws.Cells(i, "J").Value End If End If Next i netValue = 0 For Each key In dict.keys netValue = netValue + dict(key) Next key ws.Range("O5").Value = netValue End Sub الملف تجارب اجمالى العهدة.xlsb

وعليكم السلام في احد مشاريعي ، جابوا لي قائمة اكسل فيها تواريخ مكتوبة بكل ما لذ وطاب من الطرق ، مثل: 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

شرف ليا انى اضيف موضوع وسط اساتذتى https://www.mediafire.com/file/pzr38qxqwg4e2a2/Ferry_Login_v1-_free.accdb/file Ferry Login v1free.accdb

اخى الفاضل بيانات رياضة نتيجة الفضل بكود الطالب وبيانات الفصل بالثلاث ملفات رقم الجلوس يتم تكويد البيانات وفكرة التقرير لشعبة واجدة وإن شاء الله التطبيق على باقى الشعب سهل

ماشاء الله تبارك الرحمن جعله ذلك في ميزان حسناتك استاذ Foksh رد وتجاوب واقتراح

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

وعليكم السلام ورحمة الله وبركاته ,, اخي الكريم انت استخدمت الدالة DLookup لجلب رقم المقترض ( على ما أعتقد ) بناءً على اسم الموظف في الكومبوبوكس ، هل هذا صحيح ؟؟ وبإمكانك بدلاً من ذلك استخدام نفس مصدر الكومبوبوكس com1 ولكن هنا سنختار العمود رقم 2 حيث :- ( العمود 0 = اسم الموظف ، والعمود 1 = الجهة ، والعمود 2 = رقم المقترض ) ، لذا تم استبدال الجملة التالية :- Me.n2 = DLookup("[num]", "karz", "nam LIKE '*" & Me.com1 & "*'") بالجملة :- Me.n2 = com1.Column(2) أيضاً تم إجراء تعديل بسيط على عدد الأعمدة في الكومبوبوكس com1 وعرض كل عمود ؛ كما في الصورة :- الملف بعد التعديل القرضة الحسنة اصدار 31.zip

جرب هذا الكود Sub deletX() Dim x As String, ce As Range x = InputBox("What is the word you want to delete Cells contain it?") If x = "" Then Exit Sub For Each ce In Selection On Error Resume Next If Len(ce.Value) >= Len(x) And InStr(1, ce.Value, x, vbTextCompare) > 0 Then ce.ClearContents On Error GoTo 0 Next ce End Sub

السلام عليكم استاذنا الفاضل اشكر تفاعلك معي ارفق لكم البرنامج وحذفت منه معلومات لكونه كبير في فورم kabz تسديد قروض الموظفين عند ادخال اسم الموظف قسم يظهر رقم الموظف وقسم لايظهر الكود في حدث بعد التحديث لكومبو بوكس com1 اسم الموظف القرضة الحسنة اصدار 31.rar

جرب هدا في 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

شكرا لكم استاذ : Moosak

وعليكم السلام ورحمه الله وبركاته تفضل جرب هذا Customers-Project-01.xlsb

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

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

هل من الممكن التحقق من الملف الحالي ما الخطأ في الكود حاولت اضيف كود لنسخ الصورة المصافة و لصقها في رسالة واتس اب رسالة واتساب عام محدث7.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