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

Try this code Sub ToggleButton_ON_OFF() Const ONKEY As String = "On", OFFKEY As String = "Off" Dim ws As Worksheet, shOnOff As Shape, shToggle As Shape, shRadio As Shape, s As String Set ws = ActiveSheet With ws Set shOnOff = .Shapes("txtboxOnOff") Set shToggle = .Shapes("ToggleButton1") Set shRadio = .Shapes("radioButton") End With With shOnOff s = .TextFrame.Characters.Text .TextFrame.Characters.Text = IIf(s = ONKEY, OFFKEY, ONKEY) ws.Rows("12").Hidden = (s = OFFKEY) .TextFrame.HorizontalAlignment = IIf(s = ONKEY, xlHAlignLeft, xlHAlignRight) shToggle.Fill.ForeColor.RGB = IIf(s = ONKEY, RGB(232, 27, 34), RGB(117, 199, 1)) shRadio.Left = shToggle.Left + IIf(s = ONKEY, shToggle.Width - shRadio.Width - 5, 5) End With End Sub

كلام الزميل موسى صحيح، لا بد من التجارب. مع العلم أنه لا يوجد دالة between في الـ vba وعليه يمكن التعويض عنها كما مشاركة الزميل محمد لطفي. ويمكن كذلك تصميم الدالة كما التالي: Function Between(Value As Variant, MinVal As Variant, MaxVal As Variant) As Variant If VarType(Value) = VarType(MinVal) And _ VarType(Value) = VarType(MaxVal) Then Between = CBool(Value >= MinVal And Value <= MaxVal) Else Between = "Var type error" End If End Function ومناداتها كالتالي: If Between(4, 1, 10) then MsgBox "إجابة سليمة" End if

تفضل اخي جرب تم تعديل الكود لجلب بيانات جميع الطلاب بشرط اختلاف في اي درجة من درجات المواد ولو كانت واحدة فقط . وتجاهل من لهم درجات متطابقة في جميع المواد Sub comparecells_MH() Dim i&, j&, k&, m&, RwsDest&, derlig& Dim a As Variant, b As Variant Dim WSData As Worksheet: Set WSData = Sheets("الكشف") Dim WSDest As Worksheet: Set WSDest = Sheets("فرزدرجات") derlig = WSDest.Range("C" & Rows.Count).End(xlUp).Row + 1 Application.ScreenUpdating = False a = WSData.Range("C6:T" & WSData.Range("D" & Rows.Count).End(3).Row).Value ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2)) For i = 1 To UBound(a, 1) - 1 Step 2 For j = 3 To UBound(a, 2) If a(i, j) <> a(i + 1, j) Then k = k + 1 For m = 1 To UBound(a, 2) b(k, m) = a(i, m) b(k + 1, m) = a(i + 1, m) Next k = k + 1 Exit For End If Next Next WSDest.Range("C6").Resize(UBound(b, 1), UBound(b, 2)).Value = b With WSDest.Range("C6:T" & WSDest.Cells.SpecialCells(xlCellTypeLastCell).Row) If .Row < 6 Then Exit Sub For Each r In .EntireRow If Application.CountA(Intersect(r, WSDest.Range("C:D"))) Then _ If Application.CountA(Intersect(r, WSDest.Range("E:T"))) = 0 Then Intersect(r, WSDest.Range("C:D")).EntireRow.Delete Next RwsDest = WSDest.Range("D" & Rows.Count).End(xlUp).Row With WSDest.Cells(6, Columns.Count).End(xlToLeft).Offset(0, 1).Resize(RwsDest) .Formula = "=if(countifs(D:D,D6)>1,"""",1)" .Value = .Value Intersect(.SpecialCells(xlConstants).EntireRow, WSDest.Range("A:U")).Delete WSDest.Range("U6:U" & derlig).ClearContents End With End With Application.ScreenUpdating = True End Sub مطابقة درجات V1.xlsm

بالنسبة للاستعلام يمكن حلة ..... بحيث تظهر الوظائف الجديدة والمقاطعات الجديد فيه .... شغل الاستعلام all وجرب ... انشأ التقرير المطلوب انت ونحن نساعدك في المطلوب ...... ‏‏BASEN (1) - نسخة.accdb

السلام عليكم : الاعضاء الافاضل كل عام وانتم بخير .. بحلول شهر ذي الحجة اليكم . اداة ادراج التاريخ ... واستخدامها في الاكسل من خلال تواجدها في شريط الادوات للصفحة الرئيسية لكيفية استخدامها تابع الصور ... Datepicker.zip

Sub comparecells_V2() Dim i As Long, j As Long, k As Long Dim WSData As Worksheet: Set WSData = Sheets("الكشف") Dim WSDest As Worksheet: Set WSDest = Sheets("فرزدرجات") Application.ScreenUpdating = False k = 6 With WSData For i = 6 To .Range("D" & Rows.Count).End(3).Row Step 2 For j = 5 To .Cells(i, Columns.Count).End(1).Column If .Cells(i, j).Value <> .Cells(i + 1, j) Then .Rows(i & ":" & i + 1).Copy WSDest.Range("A" & k) k = k + 2 Exit For End If Next Next End With Application.ScreenUpdating = True End Sub اليك كود اخر يؤدي نفس المهمة فقط للتاكد من صحة الاكواد اخي لكي يشتغل معك الكود بشكل سليم يجب اولا تنظيم ملفك على الشكل التالي 1) لقد دكرت بان اسماء الطلاب مكررة مرتين في ملف الكشف كما جاء في ملفك المرفق. وقد اعتمدنا على هدا داخل الاكواد For i = 1 To UBound(a, 1) - 1 Step 2 يعني لابد من وجود الاسماء في وضعية متتابعة واحد تلو الاخر مع تطابق شكل كتابة الاسماء وهدا مثال على ملف اخر قمت بنسخ بياناتك عليه والتاكد من تطابق الاسماء يمكنك تجربته ووافينا بالنتيجة وهده صورة من ملفك بعد تنظيمه وحدف الاسماء الغير مكررة للتجربة TEST V2.xlsm وهدا ملفك يمكنك تجربته كدالك مطابقة درجات V2.xlsm

أنا قدمت لك كود ورفعت لك نفس المثال بعد تطبيق الدالة عليه وبه النتائج ظاهرة واضحة!! لك كل الحق أن تختار ما يناسبك أخي، أما الكود لا يعمل .. غريب "شويتين". موفق أخي. نسيت أنبهك أن تحول ملفك الأصل من xlsx إلى xlsm

ربنا ميحرمنيش منكم ابدا يا اجمل منتدي انا عضو فيه ربنا يوفقكم دائما

اسعدك الله يا استاذي

VBA codes are better than using formulas Formulas will make the file slower and bigger in size

تفضل أخي . emp_analssies.accdb

حياك الله ياغالي الخل بسيط حمل جوجل درايف على جهاز العميل ورح يكون هناك ملف خاص في جوجل داريف مربوط مع الايميل الخاص بي العميل ونت حددمسا النسخ الاحطياطي الى ملف جوجل داويف وراح يتم رفعه تلقي الى جوجل درايف عند توفرالانترنت

=IF(MONTH(I$4)=MONTH($F5);IF($H5+DAY($F5)>DAY(EOMONTH($F5;0));DAY(EOMONTH($F5;0))-DAY($F5)+1;$H5);IF(AND(MONTH(I$4)>MONTH($F5);MONTH(I$4)<MONTH($G5));DAY(EOMONTH(I$4;0));IF(MONTH(I$4)=MONTH($G5);DAY($G5);""))) SL Data (1).xlsx

أولا : شكرا على تعاونك معي ثانيا: شكرا لك على النصيحة الجميلة وإن شاء الله أخذ بها مستقبلا فى تصميم البرامج ثالثا : يوجد طلب أخير وهو: أريد بدلا ظهور رسالة " تم اضافة الصنف من قبل " أن يتم زيادة كمية الصنف وحدة واحدة فى كل مرة أضغط على تكرار الصنف وشكرا لك على كل ماقدمته لى

عملت لك دالة vba لحساب أيام الإجازة لكل شهر جرب وأخبرني Option Explicit Function Between(Value As Date, MinVal As Date, MaxVal As Date) As Boolean Between = Value >= MinVal And Value <= MaxVal End Function Function GetVacDays(ByVal StartDate As Date, ByVal EndDate As Date, inMonth As Date) As Variant Dim MinVal As Date, MaxVal As Date Dim yy As Integer, mm As Byte yy = Year(inMonth) mm = Month(inMonth) MinVal = DateSerial(yy, mm + 0, 1) MaxVal = DateSerial(yy, mm + 1, 0) If Between(StartDate, MinVal, MaxVal) Or _ Between(EndDate, MinVal, MaxVal) Or _ Between(MinVal, StartDate, EndDate) Or _ Between(MaxVal, StartDate, EndDate) Then StartDate = IIf(StartDate > MinVal, StartDate, MinVal) EndDate = IIf(EndDate < MaxVal, EndDate, MaxVal) GetVacDays = CInt(EndDate - StartDate + 1) Else GetVacDays = "" End If End Function SL_Data_02.xlsm

اتفضل بس نصيحة لوجه الله لا تستخدم الأحرف العربية فى تسمية الحقول والكائنات والعناصر وكذلك لا تحاول استخدامها فى محرر الأكواد لسببين 1- عند استخدامها تتداخل الأكواد وقد تعجز عن التعديل عليها مستقبلا وقد تعجز اساسا عن فهم الكود وبناء الجمل من النظر الى الترتيب المعكوس بسبب الأحرف العربية كما يحدث فى دوال المجال على سبيل المثال وليس الحصر 2- عند محاولة استخدام قاعدة البيانات فى ويندوز لم يتم اعداد اللغة الاقليمية الى اللغة العربية له يحدث خطأ ولا يتم تنفيذ الاوامر البرمجية وبالتالى لن تعمل القاعدة وقد لا تعرف من الرسالة أن اللغة العربية هى المشكلة ملاحظة وضعت عدد اتنين زر امر لزيادة ونقصان الكمية افضل من زيادتها بالضغط على اسم الصنف كما تريد ولكن ان اردت ذلك لا يوجد عندى ادنى مشكلة أنا وضعت أفضل تصور من وجهة نظرى آخذا فى الاعتبار كل ما خطر على بالى لإضفاء المرونة واليسر فى التعامل واخيرا اتفضل قاعدتك بعد التعديل ان شاء الله تجد ما تريد مثال إدراج الأصناف فى الفاتورة بشروط_( v 2 ).accdb