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

كثير من تصاميم HTML نتمنى ان تكون موجودة في الاكسس و ربما يصبح الحلم حقيقة عما قريب اضع بين يديكم فكرة ! فكرة جدول مبني بلغة HTML مع تلوين الاسطر عند المرور عليها آمل ان تنال على استحسانكم web.mdb

بارك الله فيك اخي نظيم =IF(C2="";"0";C2-SUM(C3:C7)-SUM(C9:C11)) التجربة 1 (1) (1).xlsx

The file is not perfect file as it has a lot of formulas that make the file slow. Generally follow the steps accurately to solve the problem of sort First select the shape that has the caption GIRLS and rename the shape from the Name Box to shpGirls Do the same step with the shape of BOYS and rename it to shpBoys Insert new module and paste the code Sub Sort_By_Boys_Girls() Dim shp As Shape, lr As Long, n As Long Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Set shp = ActiveSheet.Shapes(Application.Caller) If shp.Name = "shpGirls" Then n = 1 Else n = 2 With ActiveSheet lr = .Cells(Rows.Count, "D").End(xlUp).Row With .Sort .SortFields.Clear .SortFields.Add Key:=Range("F9"), Order:=xlAscending .SortFields.Add Key:=Range("I9"), Order:=n .SortFields.Add Key:=Range("D9"), Order:=xlAscending .SetRange ActiveSheet.Range("D9:AH" & lr) .Header = xlNo .Apply End With End With Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub Finally assign the macro named [Sort_By_Boys_Girls] to both the shapes

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

Mohamed Hicham ................. انت دكتور و الله ............... بارك الله فيك ويعطيك العلم والستر

اخي كريم بارك الله فيك اولا .............. المطلوب قيمة المتبقى تكون في في الخانة الحمراء فقط كلما اضفت مبلغ في الخانات الزرقاء في الخانة الزرقاء 150 في اليوم الاول تكون في الخانة الحمراء 1850 و اليوم الثاني 350 تكون في الخانة الحمراء 1500 وهكذا التجربة 1 (1).xlsx

ضروري ان تضع اسم الصنف وسعر الشراء وسعر البيع للقطعة الواحدة حتى تستطيع تعيين الربح للفاتولرة

اهلا ابا انس بما اني اتحاور مع صاحب خبرة في البرمجة فهذا يسهل علي كثيرا في الاجابة وسنأخذ الطلبات واحد واحد : موجودة فعلا في التعديل الاخير .. فالمثال الاخير وتجده في اول مشاركة يشتمل على ثلاث نماذج .. احدها SendWhatsMoreMsg يعرض الرسالة لكل شخص مختلفة عن الآخر يمكن ذلك عندما ننشء جدولا كرأس يحتوي على اسماء المجموعات ونربطه بجدول الأسماء ، حينها عند اختيار المجموعة وباستخدام الاستعلام يتم التصفية الخطأ الملون بالأصفر لاعلاقة له بالتقرير وذكرت ان المثال عمل معك !!! والخطأ اعتقد انه لم يجد ملف كروم التشغيلي في المكان المحدد انظر اين ملف كروم chrome.exe وهل هو في مكانه الصحيح كما هو مبين بالسطر الذي قبل الأصفر

الف شكر لحضرتك وجزاك الله خيرا الكود يعمل بشكل ممتاز

Rename the shapes from NAME BOX not the text on the shape Assign the same macro for both the shapes. I have tried at my side and the code works well Another point, you haven't execute the macro directly from the visual basic editor It has to be assigned to a shape

ربما لم افهم المطلوب بشكل صحيح لذا ضع مرفق ليتم الاطلاع عليه او شاهد الملف المرفق علما بان الامر RunMenuCommand للاصدارات 2010 فاحدث اما الاصدارات ماقبل 2010 فالامر RunCommand Database221.accdb

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

Sub Sheets_Arrays1() Dim temp As Variant Dim arr As Variant Dim F As Boolean Dim ws As Variant Dim WSdata As Worksheet: Set WSdata = Sheets("Total") For Each ws In Sheets(Array("1", "2", "3")) temp = ws.Range("k5:N" & ws.Cells(Rows.Count, 11).End(xlUp).Row).Value If F Then arr = ArrayJoin(arr, temp) Else arr = temp F = True End If Next ws With Sheets("Total") .Range("C4").Resize(1, 4).Value = Array("م", "الاسم", "الرقم الوظيفي", "سعد") .Range("C5").Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr End With End Sub '''''''''''''''''''ترحيل البيانات في اخر صف فارغ''''''''''''''''''''''' Sub Sheets_Arrays2() Dim F&, j& Dim ws As Variant Dim WSdata As Worksheet: Set WSdata = Sheets("Total") WSdata.Range("C4").Resize(1, 4).Value = Array("م", "الاسم", "الرقم الوظيفي", "سعد") For Each ws In Sheets(Array("1", "2", "3")) F = ws.Cells(Rows.Count, "K").End(xlUp).Row j = WSdata.Cells(Rows.Count, "C").End(xlUp).Row Application.ScreenUpdating = False ws.Range("K5:N" & F).Copy Destination:=WSdata.Range("C" & j + 1) Application.ScreenUpdating = True Next ws End Sub ترحيل من عدة صفحات V3.xlsm

اضافه للنابغه الأستاذ حسونه حسن يبارك له ربنا اربط هذا الكود بزر الاستدعاء Sub Test(Arr1 As Variant) ' ترحيل قائمة التلاميذ بناء على رقم الفصل '------------------------------------------------- Dim Ws As Worksheet, Sh As Worksheet Dim Arr As Variant, Temp As Variant ', Arr1 As Variant Dim LR As Long, i As Long, j As Long, p As Long '----------------------------------------- Set Ws = Sheets("المواد منفصله") Set Sh = Sheets("data1") LR = Sh.Cells(Rows.Count, 2).End(xlUp).Row Ws.Range("C5:H34").ClearContents Arr = Sh.Range("A7:AB" & LR).Value ReDim Temp(1 To UBound(Arr, 1) + 1, 0 To UBound(Arr1) + 1) For i = 1 To UBound(Arr) '------------------------------------------ If Arr(i, 4) = Ws.Range("D3").Value Then '------------------------------------------ p = p + 1 For j = 0 To UBound(Arr1) Temp(p, j) = Arr(i, Arr1(j)) Next j End If Next i If p > 0 Then Ws.Range("C5").Resize(p, UBound(Temp, 2)).Value = Temp Application.ScreenUpdating = True End Sub Sub SS_Show() Subjects.Show End Sub استدعاء بيانات بطريقه الفورمه 99(5).xlsb

تم فصل الموضوع في المرات القادمة فضلا افرد كل استفسار بعنوان يخصه .............................................. بالنسبة لطلبك الثاني تم التعديل وتجده في المرفق المصاحب اما طلبك الاول فانت بحاجة الى الإلمام ببعض المفاهيم : 1- يلزم تقسيم قاعدة البيانات الى قاعدة تضم الجداول توضع على الخادم ، وواجهات توزع على المستخدمين 2- يجب تعيين الخاصية تأمين السجلات في جميع النماذج المحررة الى : سجل محرر ( record locks to Edited Record ) وهذه الخاصية تجدها في خصائص النموذج / لسان التبويب بيانات ... آخر خصيصة من الأسفل 3- الى هنا يمكن الكتابة من الجميع ولكن ليس في اللحظة نفسها .. حيث حينما يكون احد المستخدمين يكتب يظهر عند الآخر صورة قلم في زاوية النموذج العليا تدل على ان السجل يتم تحريره 4- لتجاوز هذه المشكلة يجب ان يكون النموذج غير منضم الى الجدول ويتم الحاق البيانات بواسطة الكود vba آمل ان تجد في هذه الاسطر القليلة الفائدة المرجوة . MRN_DataBase2.rar

تفضل اخي circle.xlsm

وعليكم السلام ورحمة الله وبركاته 🙂 استغن عن الأكسبلورر بهذا الكود ( ضعه في وحدة نمطية ) واستخمه كالتالي : Option Compare Database Option Explicit Enum AttacmentsType Image = 1 Sticker = 2 Document = 3 End Enum #If VBA7 Or Win64 Then Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) Private Declare PtrSafe Function SetForegroundWindow Lib "user32.dll" (ByVal hwnd As LongPtr) As LongPtr Private Declare PtrSafe Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer #Else Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) Private Declare Function SetForegroundWindow Lib "user32.dll" (ByVal hwnd As Long) As Long Private Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer #End If Private Const VK_NUMLOCK = &H90 Public Sub SendToWhatsApp(txtPhone As String, txtMSG As String, Optional txtAttchmentPath As String = "", Optional AttachmentType As AttacmentsType = Image) '---------------------------------------(التحقق من اكتمال البيانات) If Len(txtMSG & "") = 0 Then MsgBox "يرجى كتابة الرسالة": Exit Sub If txtAttchmentPath <> "" Then If Len(Dir(txtAttchmentPath, vbDirectory)) = 0 Then MsgBox "المرفق غير موجود .. تأكد من الرابط": Exit Sub End If txtMSG = Replace(txtMSG, vbCrLf, " %0a ") txtMSG = Replace(txtMSG, Chr(10), " %0a ") txtMSG = Replace(txtMSG, Chr(13), " %0a ") '---------------------------------------(بداية الإرسال) Dim Path As String Path = "whatsapp://send?phone=" & txtPhone & "&text=" & txtMSG CreateObject("Shell.Application").Namespace(0).ParseName(Path).InvokeVerb "Open" ' إرسال الرسالة Sleep 2000 SendKeys "~" Sleep 500 SendKeys "~" ' إرسال المرفق إن وجد If txtAttchmentPath <> "" Then SendKeys "+{TAB}" SendKeys "~" Sleep 1000 Select Case AttachmentType Case Is = 1 ' صورة SendKeys "{UP}" ' لإرسال الصور ' SendKeys "{UP}" ' لإرسال الملصقات ' SendKeys "{UP}" ' لفتح الكاميرة ' SendKeys "{UP}" ' لإرسال مستند ' SendKeys "{UP}" ' لإرسال جهة إتصال Case Is = 2 ' ملصق SendKeys "{UP}" ' لإرسال الصور SendKeys "{UP}" ' لإرسال الملصقات ' SendKeys "{UP}" ' لفتح الكاميرة ' SendKeys "{UP}" ' لإرسال مستند ' SendKeys "{UP}" ' لإرسال جهة إتصال Case Is = 3 ' مستند SendKeys "{UP}" ' لإرسال الصور SendKeys "{UP}" ' لإرسال الملصقات SendKeys "{UP}" ' لفتح الكاميرة SendKeys "{UP}" ' لإرسال مستند ' SendKeys "{UP}" ' لإرسال جهة إتصال End Select SendKeys "~" Sleep 1000 SendKeys txtAttchmentPath, True SendKeys "~" Sleep 2000 SendKeys "~" Sleep 1000 SendKeys "~" End If 'If NumLock is off, turn it on If GetKeyState(VK_NUMLOCK) = 0 Then 'Send NumLock key press to turn it on SendKeys "{NUMLOCK}" End If '---------------------------------------( إعادة التركيز لبرنامج الأكسس) SetForegroundWindow Application.hWndAccessApp MsgBox " تم الإرســــــال ", vbMsgBoxRight, "" End Sub Sub test() ' لا تنس إضافة كود الدولة SendToWhatsApp "96899445566", "السلام عليكم", "C:\Users\User\Desktop\123.jpg", Image End Sub طريقة الاستخدام : SendToWhatsApp "96899445566", "السلام عليكم", "C:\Users\User\Desktop\123.jpg", Image راجع :

وفيك بارك اخى والحمد لله الذي بنعمته تتم الصالحات

السلام عليكم ورحمه الله وبركاته وبها نبدأ استاذنا الفاضل @محمدي عبد السميع تم اختصار الاكواد الثمانيه الي كود واحد فقط استدعاء بيانات بطريقه الفورمه.xlsb

تفضل هنا يتم تحويل التقرير الى ملف pdf ويتم ارساله sendwatsWeb3.rar

السلام عليكم ورحمة الله استخدم الكود التالى Sub TrMarks() Dim ws As Worksheet, Sh As Worksheet Dim Arr As Variant, Tmp As Variant Dim LR As Long, i As Long, j As Long, p As Long Dim ArCol Set Sh = Sheets("Table") Sh.Range("A11:AW" & Sh.Range("B" & Rows.Count).End(3).Row+11).ClearContents Set ws = Sheets("Mark All") LR = ws.Range("B" & Rows.Count).End(3).Row ArCol = Array(1, 2, 3, 4, 5, 6, 7, 13, 18, 19, 24, 29, 30, 35, 40, 41, _ 46, 51, 52, 57, 62, 63, 68, 73, 74, 79, 84, 85, 90, 95, 96, 101, 106, _ 107, 112, 117, 118, 123, 128, 129, 134, 139, 140, 145, 150, 151, 156, 161, 162) Arr = ws.Range("A9:FF" & LR).Value ReDim Tmp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2)) For i = 1 To UBound(Arr, 1) If True Then p = p + 1 For j = LBound(ArCol) To UBound(ArCol) Tmp(p, j + 1) = Arr(i, ArCol(j)) Tmp(p, 1) = p Next End If Next If p > 0 Then Sh.Range("A11").Resize(p, UBound(Tmp, 2)).Value = Tmp End Sub

السلام عليكم انشأت اوراق لأشهر وهمي يشترط اذا ضفت اوراق اخرى لاشهر تسميها بنفس الطريقة وعمود ارقام الايام في Sheet1 تسجل التاريخ لليوم وليس ارقام الايام كود بسيط اضافة الى حلول الاساتذه الافاضل تفضل المرفق ترحيل بيانات_1.xls

انت مبدع بمعنى الكلمة إجابة وعمل غاية في الروعة شكرا من القلب لك استاذي سليم حاصبيا ... لقد اختصرت لي الطريق في عملي الإداري انت غي غاية الكرم واعظم ما تقدمه هو العلم (إن الله يحب إذا عمل أحدكم عملاً أن يتقنه ) اتقنت في الإجابة وهذا ما اريده بالضبط شكرا لك

جرب هذا الملف (تم تعيير بعض الاشياء لحسن عمل الماكرو) الكود Option Explicit Sub filter_ME() With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With Dim lr%, k%, m%: m = 5 Dim S_sh As Worksheet: Set S_sh = Sheets("الدرجات") Dim T_sh As Worksheet: Set T_sh = Sheets("salim") Dim My_Table As Range: Set My_Table = _ S_sh.Range("A4").CurrentRegion T_sh.Range("a4").CurrentRegion.Offset(3).ClearContents With My_Table .AutoFilter .AutoFilter Field:=16, Criteria1:=T_sh.Range("d3") .AutoFilter Field:=17, Criteria1:=T_sh.Range("d2") Sheets("Sapace").Cells.Clear .Columns(18).SpecialCells(xlCellTypeVisible).Offset(1).Copy _ Destination:=Sheets("Sapace").Range("a1") .Columns(2).SpecialCells(xlCellTypeVisible).Offset(1).Copy _ Destination:=Sheets("Sapace").Range("b1") .Columns(3).SpecialCells(xlCellTypeVisible).Offset(1).Copy _ Destination:=Sheets("Sapace").Range("c1") .Columns(5).SpecialCells(xlCellTypeVisible).Offset(1).Copy _ Destination:=Sheets("Sapace").Range("d1") .AutoFilter End With '====================== lr = Sheets("Sapace").Cells(Rows.Count, 1).End(3).Row For k = 1 To lr Step 2 T_sh.Range("b" & m).Resize(, 4).Value = _ Sheets("Sapace").Range("a" & k).Resize(, 4).Value T_sh.Range("g" & m).Resize(, 4).Value = _ Sheets("Sapace").Range("a" & k + 1).Resize(, 4).Value T_sh.Range("a" & m) = k: T_sh.Range("f" & m) = k + 1 m = m + 1 If IsEmpty(T_sh.Range("G" & m - 1)) Then T_sh.Range("f" & m - 1) = vbNullString Next With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With End Sub الملف مرفق الترحيل salim.xlsm

تفضل الملف بعد التعديل مع شرح المعادلة معادلة جلب رقم الجلوس من صفحة مسودة إلى الصفحتين الأخريتين مثال على الجدول الأول بداية الجدول من عمود رقم الجلوس إلى أخر عمود به النتيجة (ناجح أم راسب) {=IF(مسودة!$G$8:$AM$37="","",IF(ISERROR(INDEX(مسودة!$C$8:$AU$37, هذه الجزئية من المعادلة ثابتة فى كل الجداول حتى لا ترحل البيانات إلا بعد تعبئة الجدول الأول من صفحة مسودة ومعناها إذا كان الجدول الأول فارغاً فلا تنقل درجات أى جدول إلى الصفحتين الأخرتين SMALL(IF((مسودة!$AU$8:$AU$37="ناجح"),ROW(مسودة!$C$8:$AU$37)- عمود النتيجة وطبعا فى صفحة الراسبون لابد أن يكتب بها راسب بدل من ناجح MIN(ROW(مسودة!$C$8:$AU$37))+1,""),ROW(A1)),COLUMN(A1))),"",INDEX(مسودة! وهذا يعنى أن يكون أول صف وأول عمود وفى رقم الجلوس اللى بعده لابد أن يتغير إلى A2 وذلك لتلاشى الفراغات بين السطور فى الصفحة المرحل إليها $C$8:$AU$37,SMALL(IF((مسودة!$AU$8:$AU$37="ناجح"),ROW(مسودة!$C$8:$AU$37 　 )-MIN(ROW(مسودة!$C$8:$AU$37))+1,""),ROW(A1)),COLUMN(A1))))} 　 هذا القوس فى بداية ونهاية المعادلة لأنها معادلة صفيف فلابد من هذان القوسين وبدونهما لا تعمل المعادلة مطلوب ترحيل الناجحين والراسبين.rar

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

السلام عليكم و رحمة الله وبركاته مقدمة لفهم الفكرة اليومين دوول بعمل جدول حصص لمدرستى و شكل توزيع المدرسين فى الجدول بيكون بالشكل ده : فى الحصة المنفردة بيكون بالشكل ده : محمد فى الخلية B2 مثلا فى الحصة المشتركة بيكون بالشكل ده : محمد + محمود فى الخلية B3 مثلا وعشان أحسب عدد حصص محمد فى الخليتين بالدالة COUNTIF كان الناتج 1 فقط ليه الناتج كان 1 مش 2 شفتوا شفتوا حتى الاكسل اللى أكل دماغنا جاى على المدرس و حسب له 1 مش 2 على الرغم من أن الاستاذ محمد الغلبان شغال فى حصتين الاولى لوحده والتانية مشتركة مع الاستاذ محمود طبعا أنا مدرس زى الأستاذ محمد فوجب عليا أن أنصره على الاكسل الظالم أحيانا وأرجع له حقه فكانت هذه الدالة المستحدثة عشان تدى الأستاذ محمد حقه وتحسب له كام حصة اشتغل فيها هذا المعلم **************** اسم الدالة : MokhtarCountif تشبه الدالة COUNTIF فى العمل مع الفارق الفارق أن دالتى تبحث عن النص حتى ان كان النص كلمة من مجموعة كلمات بالخلية تتكون الدالة من عدد 2 باراميتر : MyVal نوعه String و AddressRange نوعه Range والناتج نوعه Long Option Explicit Function MokhtarCountif(MyVal As String, AddressRange As Range) As Long ' Author : Mokhtar ' Release : 2 - 10 - 2016 ' The MokhtarCountif function counts the number of a single criterion within a cell or range Of cells ' Name Required/Optional Data Type Description ' MyVal Required String The criteria in the form of a number, expression, or text. ' AddressRange Required Range The cell or range of cells which you want to count within. ' Return Value : Long '---------------------------------------------------------------------------------------------------- Dim C As Range, Total As Long, Arr() As String, j As Integer Application.Volatile True For Each C In AddressRange.Cells Arr = Split(C, " ") For j = LBound(Arr) To UBound(Arr) If Arr(j) = MyVal Then On Error Resume Next Total = Total + 1 On Error GoTo 0 End If Next j Next C MokhtarCountif = Total End Function أتمنى أن تنال الدالة اعجابكم و منتظر ملاحظاتكم مع تحياتى MokhtarCountif udf.rar

كان احد السادة عرض نفس الموضوع سابقا منذ ايام وضعت اجابة و لكنه لم يبدي اي راي فيها .. كان طلبه كالتالي: 1- نقوم بترتيب الطلبة العشرة الاوائل وفقا لمعدلهم و بالطبع من الاكبر الى الاصغر 2- الترتيب يكون باظهار كل العشرة الاوائل مختلفي المعدل بمعنى في حالة مثلا تساوي طالبين في المعدل فانه في المحصل يظهر 11 طالب مثلا 1-2-2-3-4..الخ ( لان الترتيب النموذجي حسب الاكسل يكون باظهار العشرة الاوائل فقط و في حالة تساوي طالبين في المعدل يظهر 1-2-2-4....الخ 2- في حالة تساوي معدلات الطلاب نقوم بالتفريق بينهم على اساس السن و الاولية للاصغر سنا 3- في حالة تساوي السن تكون المفاضلة حسب الترتيب الابجدي للاسماء.......... .... النتيجة التي توصلت اليها تكون من الشكل 3/1(1) 3/1(2) و تعني 3 : ان الطالبان ترتيبهما حسب معدلهما هو الثالث 1 : ان الطالب حسب سنه هو الاول و اذاكان متساويان في السن سنجد 1 و 1 و بالتالي نذهب لقراءة الرقم وراء القوس و هو الذي يعبر عن الترتيب الابجدي New WinRAR archive.rar

الله ينور عليك يا بشمهندس سليم جزاك الله كل خير وربنا يجعله فى ميزان حسناتك ...وتسلم يا جمييييييييل

الأخ الفاضل الغندور إليك المرفق التالي .. Transfer Data Based On Two Conditions.rar

تفضلوا الملف اخوانى .ارجو المساعدة بارك الله فيكم ترحيل بيانات بشرطين.rar

انا اخوك حسام عيسى والله لو تدرى فرحتى ازاى دلوقتى انت بجد روعه فعلا صياد ماهر للمعلومه بص يا كبير انت لما فتحت With Sheet4 كان لازم تقفلها بـ End with وبعدين تبدء With Sheet3 وبعدين تقفلها بـ End with الخطا عندك انك قفلت الاولى والتانية فى الاخر والصح انك خلصت وحده تقفلها وتدخل على التانية جرب المرفق وهتلاحظ الفرق انت خلاص بقيت فنان وصياد تقبل تحياتى خزينة 2222222222.zip

اخي الكريم ... تقبل الله منا ومنكم الصيام وكل عام وانت بخير وعافية وكل اهل المنتدى الكريم طيب الله خاطرك بالخير عندي مشكلة كل الملفات التي اقوم بتحميلها من الموقع بصيغة php

السلام عليكم أخي العزيز / أ:حكيم شاكر لك مرورك الطيب جزاك الله خيرا أخي العزيز / الريفي 1-احتاج الزر الازرق يعمل مثل الزر الاحمر وممكن ان يكون المعيار مثلا هو خانة التاريخ اذكانت اكبر من الواحد فيتم الترحيل الى صفحة الفرع إذا جعلنا التاريخ معيار فقد تفقد بعض البيانات مثلا إذا لديك في سطرين مختلفين بيانين في يوم واحد (مثلا 02 January 2014) لنفس الفرع (فرع 2) فعند الضغط علي الزر وأنت بالسطر الأول سيتم النقل ولكن عند الضغط علي الزر وأنت بالسطر الثاني سيقارن التاريخ (المعيار) ويجده موجودا من قبل في صفحة الفرع فلن يتم النقل 2- بالنسبة الى تقرير الاقساط ( القسط مستحق-متاخر-مسدد) ، فاننى قد حددت المعيار بناء على عمود رصيد القسط فاذا كان رصيد القسط = صفر فانه يعنى سداد القسط ، رصيد القسط اكبر من >0 فانه يعنى متاخر اذا كان اكبر من تاريخ الاستحقاق او لم يحن تاريخ استحقاقه وضعت بيانات إضافية (افتراضية) بصفحة "المبيعات القسط" لتجربة الكود وغيرت بداية ونهاية فتره التقرير أيضا لنفس السبب (يمكنك تغيرها كما تشاء مثلا لن يلتفت للأقساط التي تاريخ استحقاقها أصغر من بداية الفتره 01/04/2014 أو أكبر من نهاية الفتره 30/05/2014 أضفت لك ايضا تنسيق شرطي في صفحة تقرير الاقساط يجعل لون القسط الذي تم سداده أخضر والذي لم يتم أحمر الكود يعمل بالضغط علي الزر الأخضر في صفحة تقرير الاقساط مرفق الملف وبه الكود الجديد a2.rar

الأستاذ / MEDO1312 السلام عليكم ورحمة الله وبركاته إليك المطلوب به المطلوب وعملت لك العلاوة الخامسة من الأساسي القديم مباشرة وتم ترحيل صفحة البيانات فقط إلى Data كما طلبت. محمد13.rar

السلام عليكم الاخ الفاضل بن عليه-----حفظه الله هل هذا ما تقصده ؟؟ Option Explicit Const RR As Integer = 157 Const CC As Integer = 26 Sub kh_SumProduct() Dim nAry() As Variant, mAry() As Variant, M_D() As Variant Dim MyCalc As XlCalculation Dim Last As Long, C As Integer, R As Integer, cN As Byte Dim Na As Range, Mo As Range, M As Range, D As Range On Error GoTo 1 '------------------------------------------ With Range("Name") Last = .Cells(.Rows.Count).End(xlUp).Row End With '------------------------------------------ Set Na = Range("Name").Resize(Last, 1) Set Mo = Range("Month").Resize(Last, 1) Set M = Range("Madine").Resize(Last, 1) Set D = Range("Daine").Resize(Last, 1) '------------------------------------------ ReDim nAry(1 To RR): ReDim mAry(1 To CC): ReDim M_D(1 To 2) '------------------------------------------ MyCalc = Application.Calculation Application.Calculation = xlCalculationManual Application.ScreenUpdating = False '------------------------------------------ M_D(1) = Kh_RgToAry(M): M_D(2) = Kh_RgToAry(D) '------------------------------------------ With Sheet4 For C = 1 To CC If C Mod 2 = 1 Then cN = 1 Else cN = 2 For R = 1 To RR If R = 1 Then mAry(C) = Kh_RgToAry(Mo, 1, .Cells(1, C + 2)) If C = 1 Then nAry(R) = Kh_RgToAry(Na, 1, .Cells(R + 3, 2)) .Cells(R + 3, C + 2) = WorksheetFunction.SumProduct(nAry(R), mAry(C), M_D(cN)) Next Next End With 1: Application.Calculation = MyCalc Application.ScreenUpdating = True '------------------------------------------ Erase nAry: Erase mAry Set Na = Nothing: Set Mo = Nothing: Set M = Nothing: Set D = Nothing End Sub Function Kh_RgToAry(MyRng As Range, Optional T As Variant, Optional Test As Variant) Dim co As Range, i As Long, Tb As Boolean ReDim MyAr(1 To MyRng.Cells.Count) For Each co In MyRng.Cells i = i + 1 If IsMissing(T) Or IsMissing(Test) Then MyAr(i) = CDbl(co) Else Select Case Val(T) Case 1: Tb = co = Test Case 2: Tb = co <> Test Case 3: Tb = co > Test Case 4: Tb = co < Test End Select MyAr(i) = Abs(CInt(Tb)) End If Next Kh_RgToAry = MyAr Erase MyAr End Function شاهد المرفق kh_SumProduct.rar ودمتم في حفظ الله

السلام عليكم اضغط الزر اللي امامك في المرفق Statement of Account (24.12.11) 2.rar

السلام عليكم أشكر جميع من قاموا بالرد جزاكم الله خيرا أستاذى و معلمى الحسامى شهادة أعتز بها أستاذى أبو أحمد جزاك الله خبرا أستاذى khhanna شكرا لثنائك الطيب أستاذى الحبيب " الجزيرة " بوركت و شكرا لتعليقك الطيب جزاكم الله خيرا جميعا

السلام عليكم ورحمة الله وبركاتهإن شاء الله يكون طلبك بالمرفق abo_akram.rar