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

يمكنك وضع الكود التالي في Private Sub Workbook_Open Private Sub Workbook_Open() ' هنا اسماء الاجهزة المسموح للمصنف الاشتغال عليها If Environ("computername") <> "CFAMURAD" And Environ("computername") <> "Officena" Then 'عند عدم تحقق الشرط يتم اظهار الرسالة وغلق الملف Application.DisplayAlerts = False MsgBox " لا يمكنك تشغيل هدا المصنف على هدا الكمبيوتر " & _ vbLf & vbLf & " .......... المرجوا الاتصال", _ vbOKOnly + vbExclamation + vbDefaultButton1 + vbApplicationModal, "معلومات" ThisWorkbook.Close Application.DisplayAlerts = True End If End Sub يستحسن وضع باسوورد لمحرر الاكواد لكي لا يتم التلاعب بالملف فتح المصنف على اجهزة محددة.rar

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي Sub Extract_The_differences() '================02/07/2024 by:MOHAMEED HICHAM www.officena.net "منتدى الاكسيل" ' '=========================================================================================== Dim a(1), b, i&, arr&, n&, x&, lr&, dic As Object Set dic = CreateObject("Scripting.Dictionary") Dim srcWS As Worksheet: Set srcWS = Sheets("النتائج") rCrit = [{1,2,12,13,14,18}] ''<======= ' تحديد اعمدة المقارنة With Sheets("2023") With .Range("a10", .Range("a" & Rows.Count).End(xlUp)).Resize(, 18) a(0) = Application.Index(.Value, _ Evaluate("row(2:" & .Rows.Count & ")"), rCrit) End With End With For i = 1 To UBound(a(0), 1) dic(a(0)(i, 1)) = Array(i, Join(Application.Index(a(0), i, 0), Chr(2))) Next With Sheets("2022") With .Range("a10", .Range("a" & Rows.Count).End(xlUp)).Resize(, 18) a(1) = Application.Index(.Value, _ Evaluate("row(2:" & .Rows.Count & ")"), rCrit) End With End With ReDim b(1 To UBound(a(1), 1), 1 To UBound(a(1), 2) * 2 + 2) For i = 1 To UBound(a(1), 1) If dic.exists(a(1)(i, 1)) Then If dic(a(1)(i, 1))(1) <> Join(Application.Index(a(1), i, 0), Chr(2)) Then n = n + 1 For arr = 1 To UBound(a(1), 2) b(n, arr) = a(1)(i, arr) b(n, arr + UBound(b, 2) / 2) = a(0)(dic(a(1)(i, 1))(0), arr) If b(n, arr) <> b(n, arr + UBound(b, 2) / 2) Then b(n, UBound(b, 2)) = b(n, UBound(b, 2)) + 1 End If Next End If End If Next With srcWS Application.ScreenUpdating = False With .Rows("5:" & .Cells.SpecialCells(11).Row) .ClearContents: .Interior.ColorIndex = xlNone End With If n Then .[A5].Resize(n, UBound(b, 2)) = b '[تنسيق الاختلافات] On Error Resume Next With .Rows(4).SpecialCells(2).Areas(2) With .CurrentRegion.Resize(, .Columns.Count - 1) .FormatConditions.Delete .FormatConditions.Add 2, Formula1:="=" & .Cells(1).Address(0, 0) & "<>A4" .FormatConditions(1).Interior.Color = RGB(255, 204, 0): Set Rng = srcWS.[N5:N1000] On Error GoTo 0 End With End With End If End With Application.ScreenUpdating = True MsgBox Application.WorksheetFunction.Sum(Rng) & _ " " & ": عدد الاختلافات", vbInformation, " مقارنة 2022 / 2023 " End Sub مقارنة اعمدة معينة على ورقتين.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته استبدل =Feuil14!C9+Feuil14!F9+Feuil14!I9+Feuil14!L9+Feuil14!O9+Feuil14!R9+Feuil14!U9+Feuil14!X9+Feuil14!AA9+Feuil14!AD9+Feuil14!AG9+Feuil14!AJ9 بالمعادلة التالية =IF($B$6=1;Feuil14!C9;IF($B$6=2;SUM(Feuil14!C9+Feuil14!F9);IF($B$6=3;SUM(Feuil14!C9+Feuil14!F9+Feuil14!I9);IF($B$6=4;SUM(Feuil14!C9+Feuil14!F9+Feuil14!I9+Feuil14!L9);IF($B$6=5;SUM(Feuil14!C9+Feuil14!F9+Feuil14!I9+Feuil14!L9+Feuil14!O9);IF($B$6=6;SUM(Feuil14!C9+Feuil14!F9+Feuil14!I9+Feuil14!L9+Feuil14!O9+Feuil14!R9);IF($B$6=7;SUM(Feuil14!C9+Feuil14!F9+Feuil14!I9+Feuil14!L9+Feuil14!O9+Feuil14!R9+Feuil14!U9);IF($B$6=8;SUM(Feuil14!C9+Feuil14!F9+Feuil14!I9+Feuil14!L9+Feuil14!O9+Feuil14!R9+Feuil14!U9+Feuil14!X9);IF($B$6=9;SUM(Feuil14!C9+Feuil14!F9+Feuil14!I9+Feuil14!L9+Feuil14!O9+Feuil14!R9+Feuil14!U9+Feuil14!X9+Feuil14!AA9);IF($B$6=10;SUM(Feuil14!C9+Feuil14!F9+Feuil14!I9+Feuil14!L9+Feuil14!O9+Feuil14!R9+Feuil14!U9+Feuil14!X9+Feuil14!AA9+Feuil14!AD9);IF($B$6=11;SUM(Feuil14!C9+Feuil14!F9+Feuil14!I9+Feuil14!L9+Feuil14!O9+Feuil14!R9+Feuil14!U9+Feuil14!X9+Feuil14!AA9+Feuil14!AD9+Feuil14!AG9);IF($B$6=12;SUM(Feuil14!C9+Feuil14!F9+Feuil14!I9+Feuil14!L9+Feuil14!O9+Feuil14!R9+Feuil14!U9+Feuil14!X9+Feuil14!AA9+Feuil14!AD9+Feuil14!AG9+Feuil14!AJ9))))))))))))) و =IF(Feuil1!$B$6>="1";SUMIFS(Feuil5!$E$11:$E$727;Feuil5!$B$11:$B$727;B9;Feuil5!$D$11:$D$727;$C$7);0) قم باستبدالها ب =SUMIFS(Feuil5!$E$10:$E$1000;Feuil5!$B$10:$B$1000;B9;Feuil5!$D$10:$D$1000;$C$7) جلب البيانات حسب 2 الشهر.rar

تعديل مرفق استاذ @Foksh 😇 1- ان شاء كود لكافة عناصر الفورم فقط اختيار النموذج 2- يفتح حدث الفورم فقط لصق ctrl +V ملاحظة فقط اضافة حدث عند الفتح حتى لو كان فارغ admin.rar

Sub RemoveChars() Dim lr&, Cel As Range, A As String, r As Range lr = Cells(Rows.Count, "b").End(xlUp).Row Application.ScreenUpdating = False Set r = Range("b2:b" & lr) For Each Cel In r A = Replace(Cel.Value, ",", " ") Cel.Value = A Next Cel Application.ScreenUpdating = True End Sub

وعليكم السلام ورحمة الله وبركاته تفضل =SUBSTITUTE(B2;",";" ")

احببت ان افرد موضوعي هذا بعنوان مستقل 1-لان غالب او جميع الدروس هنا تتعامل مع واتساب ويندوز 2-وحتى يكون تطوير هذا العمل مستقلا ولا يحدث خلط بين الامثلة المثال المرفق تم تطبيقه على واتساب ويب واليكم بعض التوجيهات والملاحظات : كانت مشكلتي في محاولات سابقة انه في كل مرة يتم الارسال وفتح الواتساب ويب .. فانه يطلب ربطا جديدا بالجوال وبحمد الله توصلت الى حل هذه المشكلة التي كانت عائقا حقيقيا .. يكتفى بالارتباط مرة واحدة فقط الآن : عند كل ارسال يفتح الواتس ويب بشاشة جديدة .. فان كانت هناك نسخة مفتوحة من قبل فانه يتجاهلها وتصبح غير فعالة وهذه لا مشكلة فيها لأنه يفتح على الحساب نفسه . ارجوا من اخوتي واحبتي الذين يمرون من هنا تجربة المثال وافادتي بنتيجة التجربة ، من اجل الانتقال الى الخطوة التالية وهي ارسال المرفقات ملحوظة : المرفق sendwatsWebAll .. هو النسخة المحدثة والمطورة بعد أخذ آراء وتجارب الإخوة sendwatsWeb.mdb sendwatsWebAll.rar

تفضل تم التعديل كخطوة اولى راجع الجداول .. وحاول انك تصحح او بمعنى اصح تكمل بيانات الطلاب ( يوجد بعض بيانات الطلاب اتمسحت بعد التعديل ) لاني ما حبيت احذف الطلاب (اكثر من الف طالب ) ، والأفضل بما اننا نبدأ من جديد اننا نكتفي بعدد معقول من الطلاب موزعين على الصفوف والفصول بما لا يزيد عن 50 طالب ادرس الجداول جيدا واي شيء لم تفهمه اسأل schoolDb.rar

السلام عليكم ورحمه الله وبركاته دكتورنا الفاضل Foksh دا اسم مستعار للبروف المبدع ( فادي ) أو ابو وسام وليس فايد بعتذر عن المقاطعه بس اعتقد حضرتك اللي بتستعجل فالردود راجع التعليقات من الاول بتأني هتلاقي طلب حضرتك تم حله بواسطه البروف فادي والعلامه أبو خليل أو تنتظر لحين اكتمال الاسطوره أبو جودي من انتهائه من عمل الملف اللي حضرتك استخدمته قبل كده ليكون سهل عليك استخدامه أعتذر مره اخري عن المقاطعه دي مجرد وجهه نظرى لو أسأت الفهم يمكن تجاهلها تحياتي

استخدم نموذج فرعي للساعة بحيث يكون منفصل ، وفي النموذج الرئيسي اجعل التايمر مخصص فقط للهدف الثاني . ويوجد حل آخر لكن هذا افضل وأضمن لك

أسعد الله قلبك ، أخي @Zooro1 شرف لي تقديم معلومة لهذا المنتدى

المفروض انك تعلم ما يفعله الكود هو في الاصل لا يقوم بالتفريغ وانما يقوم بنسخ بيانات الاسم الموجود في الخلية F1 وبما ان الاسم مكرر اكثر من مرة مع وجود فراغات في الاعمدة المقابلة يقوم بنسخ لك قيمة فارغة لان تركيبة الكود هي جلب جميع بيانات الاسم حاول وضع تواريخ امام اسم محمد مثلا وتجربة الكود لتتضح لديك الفكرة بعد تنفيد الكود

ما الغرض من فك حماية جميع اوراق العمل لتقوم بافراغ الخلايا المحددة على ورقة عمل واحدة جرب هدا Sub Protect() Dim x As Worksheet Set x = ActiveSheet Application.ScreenUpdating = False x.Unprotect "bac20022002" With Selection .ClearContents End With x.Protect "bac20022002" Application.ScreenUpdating = True End Sub

وعليكم السلام ورحمة الله تعالى وبركاته اعتقد اخي الفاضل ان انسب طريقة لدالك هي استخراج القيم التي يساوي مجموعها القيمة المدخلة في عمود مغاير لان الاعتماد على التظليل ممكن يسبب لك تداخل في النتائج المتوقعة عند تواجد نفس الرقم في اكثر من احتمال مثال لو اردنا استخراج الاعداد الخاصة ب 34 مع وجود الارقام التي قمت بدكرها في مشاركتك سنعثر على نفس الارقام مكررة في اكثر من احتمال 👇 لتتفادى هدا ممكن استخدام الدالة التالية مثال لعملية استخراج القيم المتوقعة 👈 لنفترض ان الخلية المخصصة لادخال المجموع هي B2 In cell B2 =IFERROR(TRANSPOSE(xFormula(A2:A11; B2));"") وفي Module انسخ الكود التالي مع حفظ الملف بصيغة الماكرو Option Explicit '================29/06/2024 by:MOHAMEED HICHAM www.officena.net "منتدى الاكسيل" ' '=========================================================================================== Public Function xFormula(rngNumbers As Range, XSum As Long) Dim arNumbers() As Long, tmp() As Long, arr() As String, F As Range, Cnt As Long ReDim arr(0) If rngNumbers.Count > 1 Then ReDim arNumbers(rngNumbers.Count - 1) Cnt = 0 For Each F In rngNumbers arNumbers(Cnt) = CLng(F.Value) Cnt = Cnt + 1 Next F Call Cpt(arNumbers, XSum, tmp(), arr()) End If ReDim Preserve arr(0 To UBound(arr) - 1) xFormula = arr End Function Private Sub Cpt(Numbers() As Long, target As Long, tmp() As Long, ByRef arr() As String) Dim s As Long, i As Long, j As Long, num As Long Dim Rng() As Long, tmpRec() As Long, n As Long s = a(tmp) If s = target Then n = UBound(arr) ReDim Preserve arr(0 To n + 1) arr(n) = b(tmp) End If If s > target Then Exit Sub If (Not Not Numbers) <> 0 Then For i = 0 To UBound(Numbers) Erase Rng() num = Numbers(i) For j = i + 1 To UBound(Numbers) Total Rng, Numbers(j) Next j Erase tmpRec() C tmpRec, tmp Total tmpRec, num Cpt Rng, target, tmpRec, arr Next i End If End Sub Private Function b(x() As Long) As String Dim n As Long, result As String result = " " & x(n) For n = LBound(x) + 1 To UBound(x) result = result & "-" & x(n) Next n result = result & " " b = result End Function Private Function a(x() As Long) As Long Dim n As Long a = 0 If (Not Not x) <> 0 Then For n = LBound(x) To UBound(x) a = a + x(n) Next n End If End Function Private Sub Total(arr() As Long, x As Long) If (Not Not arr) <> 0 Then ReDim Preserve arr(0 To UBound(arr) + 1) Else ReDim Preserve arr(0 To 0) End If arr(UBound(arr)) = x End Sub Private Sub C(destination() As Long, source() As Long) Dim n As Long If (Not Not source) <> 0 Then For n = 0 To UBound(source) Total destination, source(n) Next n End If End Sub ادا كنت تستخدم النسخ الحديثة من الاوفيس ضع المعادلة التالية في الخلية E2 للتحقق من مجموع القيم المستخرجة مع سحبها للاسفل =IF(D2<>"";SUM(FILTERXML("<x><y>"&SUBSTITUTE(TRIM(CONCAT(IFERROR(0+MID(D2;SEQUENCE(LEN(D2));1);" ")));" ";"</y><y>")&"</y></x>";"//y"));"") فحص مجموعة قيم لايجاد اى منها يساوى قيمة معينة.xlsm

اذا كنت قد فهمت طلبك بشكل صحيح فالتعديل التالي سوف يوفي بالغرض Option Compare Text Dim a, i As Long Dim OneRng(), Rng, rCrit1, rCrit2 Dim d As Object, ComboAry As Variant Private Const Cpt As String = "Compte magasin" Private Const tbl As String = "Table1" Dim Crit(), headers(), choix(), colClé, Cnt, Item_Code Private Sub UserForm_Initialize() Dim Irow& Set f = Sheets(Cpt) a = Sheets(Cpt).ListObjects("Table1").DataBodyRange.Columns("A:X") Set d = CreateObject("scripting.dictionary") d.CompareMode = vbTextCompare Irow = f.Columns("I:N").Find(What:="*", SearchDirection:=xlPrevious, _ SearchOrder:=xlByRows).Row Set Cnt = f.Range("G2:N" & Irow): Crit = Cnt.value headers = Application.Index(Cnt.Offset(-1).value, 1) Me.ComboBox10.List = Application.Transpose(f.Range("J1:N1").value) ComboAry = Array("ComboBox1", "ComboBox3", "ComboBox5", _ "ComboBox9", "ComboBox10", "ComboBox13", "ComboBox12") For i = 0 To UBound(ComboAry): Me.Controls(ComboAry(i)).value = "*": Next i '''''''' Code..... ''''''''''''''''''''' End Sub ******************************************************************** Private Sub ComboBox10_Change() Item_Code = Val(Me.ComboBox12): Prices = Me.ComboBox10 If IsNumeric(Me.ComboBox10) Then _ tmp = Val(Me.ComboBox10) Else tmp = Prices colClé = Application.Match(tmp, headers, 0) For i = LBound(Crit) To UBound(Crit) If UCase(Crit(i, 1)) = UCase(Item_Code) And _ Prices <> "*" Then Me.TextBox7.value = Crit(i, colClé) Next i End Sub بيانات فاتورة 3.xlsm

وللحماية من فتح ملفات Excel على الجوال يمكنك استخدام الكود التالي في VBA: Private Sub Workbook_Open() If Application.OperatingSystem Like "*phone*" Then MsgBox "لا يمكن فتح هذا الملف على الهاتف الجوال", vbExclamation ThisWorkbook.Close SaveChanges:=False End If End Sub يقوم الكود بفحص نظام التشغيل الذي يعمل عليه Excel، وإذا كان النظام هو هاتف جوال فسيتم عرض رسالة تنبيه تخبر المستخدم بأنه لا يمكن فتح الملف على الهاتف الجوال وسيتم إغلاق الملف دون حفظ التغييرات. يمكنك إضافة هذا الكود في "ThisWorkbook" في محرر الفيجوال بيسيك لتطبيقه عند فتح الملف.

كود VBA لحذف الشيتات المخفية في ملف Excel عند محاولة فتحها في الجوال وعدم حذفها عند فتحها في اللابتوب: Private Sub Workbook_Open() Dim ws As Worksheet Dim deleteHiddenSheets As Boolean Dim operatingSystem As String operatingSystem = Application.OperatingSystem If operatingSystem Like "*phone*" Then deleteHiddenSheets = True Else deleteHiddenSheets = False End If If deleteHiddenSheets Then Application.DisplayAlerts = False For Each ws In ThisWorkbook.Sheets If ws.Visible = xlSheetHidden Then ws.Delete End If Next ws Application.DisplayAlerts = True End If End Sub يقوم هذه الكود بفحص نوع نظام التشغيل وفي حال كان النظام هو هاتف (جوال)، سيتم حذف جميع الشيتات المخفية. وإذا كان النظام ليس هاتف (مثل اللابتوب)، لن يتم حذف الشييتات المخفية. يمكنك استخدام هذا الكود في ملف Excel الخاص بك لتحقيق ذلك.

ويمكنك استخدام الكود التالي لمنع فتح ملف Excel عبر الجوال وإخفاء جميع الأوراق في الملف: Private Sub Workbook_Open() If Application.UserName = "اسم المستخدم هنا" And Application.OperatingSystem Like "*phone*" Then MsgBox "غير مسموح بفتح هذا الملف عبر الجوال", vbExclamation ThisWorkbook.Close False Else Dim ws As Worksheet For Each ws In ThisWorkbook.Sheets ws.Visible = xlSheetHidden Next ws End If End Sub يجب استبدال "اسم المستخدم هنا" بالاسم المستخدم الذي تريد منعه من فتح الملف عبر الجوال. يقوم الكود أولاً بالتحقق إذا كان المستخدم هو المستخدم المحدد وإذا كان نظام التشغيل هو الهاتف، سيتم عرض رسالة تنبيه وإغلاق الملف، وإلا سيتم إخفاء جميع الأوراق في الملف.

يمكنك اظافة اسم ورقة العمل داخل الكود بهدا الشكل Private Sub CommandButton1_Click() Dim sh As Worksheet Set sh = Sheets("Sheet1") Sum = Evaluate("=SUMIFS(" & sh.Name & "!F3:F100000," & _ sh.Name & "!B3:B100000,"">=""&" & sh.Name & "!I2,B3:B100000,""<=""&" & sh.Name & "!j2)") Me.TextBox1.Value = Format(Sum, "#,##0.0") End Sub او الاعتماد على مربع Combobox لاختيار ورقة العمل المرغوب تنفيد الكود عليها Private Sub UserForm_Initialize() For Each s In ActiveWorkbook.Sheets Me.ComboBox1.AddItem s.Name Next s End Sub '******************** Private Sub CommandButton1_Click() If Me.ComboBox1 <> "" Then X = Me.ComboBox1.Value Set n = ThisWorkbook.Sheets(X) Sum = Evaluate("=SUMIFS(" & n.Name & "!F3:F100000," & n.Name & "!B3:B100000,"">=""&" & n.Name & _ "!I2,B3:B100000,""<=""&" & n.Name & "!j2)") Me.TextBox1.Value = Format(Sum, "#,##0.0") End If End Sub sumif v2.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Private Sub CommandButton1_Click() Sum = Evaluate("=SUMIFS(F3:F100000,B3:B100000,"">=""&I2,B3:B100000,""<=""&j2)") Me.TextBox1.Value = Format(Sum, "#,##0.0") End Sub sumif.xlsm