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

أبدأ بحمد الله أولا وأخيرا على ما انعم ووفق وأصلي واسلم على الرحمة المهداة والسراج المنير نبينا محمد وعلى آله وصحبه وسلم ... وبعد كل عام وأنتم بخير وأعاد الله علينا أيامه الكريمة بالخير واليمن والبركات في موضوع اخي الكريم ابو عبدالرحمن وطلبه لواجهة برنامج لتسجيل الأطفال لرياض الاطفال او الروضة علي هذا الرابط فضلت ان تكون في مشاركة منفصلة لتعميم الفائدة ان شاء الله تعالى بشكل بسيط وجذاب صدقة جارية لفارس من فرسان منتدانا أوفيسنا أخي ومعلمنا عماد الحسامي رحمة الله عليه ورحم جميع المسلمين وغفر لهم الأحياء منهم والأموات حتي لا أطيل عليكم شرح مبسط للبرنامج أترككم لتجربة البرنامج في المرفقات وارحب بمشاركتكم في اجراء اية تعديلات وفقنا الله واياكم للصالحات مع تحياتي // ضاحي الغريب KG_Dahy.rar الان الاصدار الثاني علي الرابط التالي اضغط هنا

اخواني السلام عليكم لوحط في الفترة الاخيرة عدة امور تعيق من يتطوع بالمساعدة في هذا المنتدي الذي ننتمي اليه جميعا ونريد ان نري تفاعلا به بالشكل الذي يستفيد منه اكبر عدد ممكن ولا يجعل المتطوع يمل لكثرة المواضيع التي تطلب اياما للرد عليها مثلا نجد - وضع عدة نقاط في مشاركة من عضو ما ويريد عمل برنامج بناء علي هذه النقاط التوضيح المنتدي ولا اخص اي مستوي من مستويات العضوية موجودين بالفعل للمساعدة للتعليم او لايجاد حل لمشكلة بفكرة افضل واسهل او ايجاد للفكرة من اساسه وليس لعمل برنامج كامل ولكن قد يقوم احد الاعضاء بعمل برنامج لعمله ووجد البرنامج (او صادفه) قد يستفيد منه احد او يكون اداة للتعلم وهذا لا يوجد مانع منه اما ان تطلب برنامج كامل اذا فانت لا تريد ان تتعلم بل تريد استنزاف وقت من يحاول مساعدتك - بعض الاعضاء يطلب طلبا واذا حدث تاخر الرد عليه يفتح موضوع جديد بنفس الطلب فتجد اشخاصا يردون عليه هنا واخرون هناك مما يستنزف الوقت والجهد فبرجاء المساعدة لنا جميعا ليستفيد الجميع تحياتي

بعد اذن اخي ياسر A لو كانت الكلمات في العامود اكتب هذه المعادلة واسحب نزولا ( معادلة صفيف) =IF(A1<>"",SUM(MATCH(MID(A1,ROW(INDIRECT("1:"&LEN(A1))),1),{"ا";"ب";"ت";"ث";"ج";"ح";"ح";"د";"ذ";"ر";"ز";"س";"ش";"ص";"ض";"ط";"ظ";"ع";"غ";"ف";"ق";"ك";"ل";"م";"ن";"ه";"و";"ي"},0)),"")

اخي الفاضل هذان السطرا تم ايقافهما بالعلامة الموضوعة علي يسار كل سطر 'PURPOSE: Different ways to find the last row number of a range 'SOURCE: www.TheSpreadsheetGuru.com هذان السطران تعريف لمتغيرات يختارها المبرمج ويقوم بتعريف البرنامج عليه وعلي ماذا تشير Dim sht As Worksheet Dim LastRow As Long هذا السطر جعل المبرمج احد المتغيرات عندما يذكرها فانها تشير الي الشيت رقم 1 في هذا الملف Set sht = ThisWorkbook.Worksheets("Sheet1") هذا السطر تم ايقافه 'Ctrl + Shift + End هنا يعرف المبرمج المتغير الثاني وهو يشير الي الصف الاخير للخلاياالغير فارغة في العمود الاول من الشيت الاول LastRow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row هذا السطر تم ايقافه(ويعتبر كعنوان لايؤثر في الكود) 'Using UsedRange هنا يتم معرفة مدي الخلايا المستخدمة sht.UsedRange 'Refresh UsedRange هنا جعل المتغير الثاني يساوي اخر صف في صفوف المدي المستخدم LastRow = sht.UsedRange.Rows(sht.UsedRange.Rows.Count).Row هذا السطر تم ايقافه(ويعتبر كعنوان لايؤثر في الكود 'Using Table Range هنا جعل المتغير الثاني يساوي عدد صفوف الجدول المستخدم LastRow = sht.ListObjects("Table1").Range.Rows.Count هذا السطر تم ايقافه(ويعتبر كعنوان لايؤثر في الكود 'Using Named Range هنا جعل المتغير الثاني يساوي عدد صفوف مدي مخفوظ LastRow = sht.Range("MyNamedRange").Rows.Count هذا السطر تم ايقافه 'Ctrl + Shift + Down (Range should be first cell in data set) هنا جعل المتغير الثاني يساوي عدد صفوف الخلايا المستخدمة LastRow = sht.Range("A1").CurrentRegion.Rows.Count End Sub ارجو ان تكون هناك افادة تحياتي

الأخ الكريم غرب الإكسيل (متخليك شرق عشان تكون معانا) جرب الدالة المعرفة التالية علها تفي بالغرض Function CalcString(S As String) Dim ArrLetters, ArrValues, X() As Byte, SpaceCounter As Long Dim I As Long, Counter As Long, Pos& ArrLetters = Join(Array("أ", "ا", "إ", "ب", "ت", "ث", "ج", "ح", "خ", "د", "ذ", "ر", "ز", "س", "ش", "ص", "ض", "ط", "ظ", "ع", "غ", "ف", "ق", "ك", "ل", "م", "ن", "ه", "ة", "و", "ي")) ArrValues = Array(1, 1, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 26, 27, 28) X = StrConv(S, vbFromUnicode) For I = 0 To UBound(X) Pos = InStr(ArrLetters, Chr(X(I))) If Pos > 0 Then Counter = Counter + ArrValues((Pos - 1) / 2) Next I SpaceCounter = SpaceCount(S) CalcString = Counter - SpaceCounter End Function Function SpaceCount(ByVal strLine As String) As String Dim Str As String Dim TempCount As Long Dim I As Long Str = Trim(strLine) TempCount = 0 For I = 1 To Len(Str) If Mid(Str, I, 1) = " " Then TempCount = TempCount + 1 Else If TempCount > 0 Then SpaceCount = SpaceCount & " " & TempCount TempCount = 0 End If End If Next I SpaceCount = Mid(SpaceCount, 2) End Function وإليك الملف المرفق Sum Letters.rar

نجحت والحمد لله اولا واخيرا نجحت والحمد لله اولا واخيرا نجحت والحمد لله اولا واخيرا وشكرا لك يا مبدع يا مهندس الابداع يا ابو براء يا ابوالهندسة كلها حماك الله في حلك وترحالك وفي مشيك ونومك ويقظتك وعفا عنك وغفر لك ولوالديك ووسع عليك واعطاك ما تتمنى في الدنيا والاخرة "اشتغلت الدالة "

اخي الخازمي اليك شرح الكود مسح محتويات المدي Range("c13:E41").ClearContents عمل حلقة استمرارية علي كل شيتات الملف For i = 1 To Sheets.Count تجنيبب الشيت المفتوح من الحلقة الاسمرارية If Sheets(i).Name <> ActiveSheet.Name Then عمل متغير لنعرف منه اخرصف في العمود الثالث في شيت الورقة1 n = Sheets("æÑÞÉ1").Range("c12").End(xlDown).Row عمل حلفة استمرارية اخري من الصف 13 والي اخر صف العامود السابق ذكره مع افتراض ان هذا العامود عدد الصفوف المستعملة به مـساو لنفس العاامود في بباقي الشيتتات وهنا يمر الكود علي صف صف في العامود For r = 13 To n ليتحقق الشرط التالي وهو لو ان الخلية في صف من صفوف الشيتات المعمول لها حلقة استمرارية تساوت مع الخلية "d5" If Sheets(i).Cells(r, 4) = [d5] Then عند ذلك يتم ترحيل محتويات الصف من العامود 3 الي العامود 5 With Columns(3).Rows(41).End(xlUp) .Offset(1, 0) = Sheets(i).Cells(r, 3) .Offset(1, 1) = Sheets(i).Cells(r, 4) .Offset(1, 2) = Sheets(i).Cells(r, 5) End With End If لاستمرار الحلقة الاستمرارية الثانية علكل صف في الشي حتي ينتهي منها Next End If لاستمرار الحلقة الاستمرارية الاولي والانتقال لشيت اخر حتي ينتهي من كل الشيتات Next ارجو ان اكون وفقت في الشرح تحياتي

السلام عليكم جرب المرفق تعبئة الخلية1.rar

السلام عليكم إخوتي الكرام... أبليتم بلاء حسناً...جزاكم الله خيراً عليه....أستاذي وحبيبي في الله أبو البراء...كود رائع يستحق الشكر والثناء...دون رفع قبعات لأنني مثلك فيما ذكرت وأظنني وجدته يعمل بشكل رائع عند كتابة مجموعة أحرف (حوالي 10 أحرف) والأروع من ذلك أنك طرحت الفراغات من عدد الأحرف التي سيحسب مجموعها. فهل وجد الأخ West Excel ضالته أم أنه يستزيد.. أما عن أخي وحبيبي في الله عبد العزيز فهديتك الخاصة رائعة للأستاذ أبو البراء...اللهم زد وبارك...مرورك عطر وورودك زينت بها مشاركاتك الطيبة ...أخي الحبيب محمد الخازمي المبادر لعمل الخير...جزاك الله خيراً..ووفقك إلى مرضاته وطاعته أنت وكل من يقرأ مشاركتي هذه.. وأقول لكم ما قاله الشعراء للأساتذة الكرام المتواضعين لشرف العلم - ما ذكرني بهذا رفع القبعة - إخوتي الكرام: ملأى السنابل تنحني بتواضع والفارغات رؤوسهن شوامخ وهذا بيت آخر يقول فيه: تواضع تكن كالنجم لاح لناظر على صفحات الماء وهو رفيعُ فما أحسن ذلك التواضع الذي تتحلون به....تقبلوا تحياتي العطرة والسلام عليكم ورحمة الله وبركاته.

السلام عليكم ورحمة الله وبركاته وبعد ,,, أقدم لكم اخوتى الأفاضل كودا يقوم بفحص نطاق من الخلايا ويحدد فقط الخلايا التى تحوى معادلات ذات القيم الخاطئة ويميزها بالتلوين أو التعديل أو التفريغ أو بعمل فلاش لتلك الخلايا لك الخيار فى اختيار شكل التمييز المناسب الكود وعليه شرح بعض السطور : Option Explicit Private Declare Function sndPlaySound32 Lib "winmm.dll" _ Alias "sndPlaySoundA" (ByVal lpszSoundName _ As String, ByVal uFlags As Long) As Long Sub CheckRangeForError() ' by mokhtat 2/10/2015 ' Error values include #DIV/0!, #N/A, #NAME?, #NULL!, #NUM!, #REF!, and #VALUE!. Dim C As Range Dim i As Integer Dim PlaySound As Boolean ' تحديد نطاق الفحص Sheets("Sheet1").Range("A2:F20").Select ' تحديد الخلايا التى تتضمن أخطاء Selection.SpecialCells(xlCellTypeFormulas, 16).Select ' استدعاء صوت من أصوات الويندوز للتنبيه على انتهاء الفحص PlaySound = True If PlaySound Then Call sndPlaySound32("C:\windows\media\notify.wav", 1) ' حدد الصوت المفضل لك طبقاً للمسار المقابل End If ' رسالة الى المستخدم بسؤال عن الرغبة فى التمييز أم لا If MsgBox(" تم انتهاء الفحص , هل تريد تمييز الخلايا ؟ ", vbYesNo + vbQuestion) = vbNo Then Exit Sub ' فى حالة اختيار لا يتم الخروج من الاجراء Else ' فى حالة اختيار تعم يتم عمل تمييز للخلايا بالتفريغ أو بالتعديل أو التلوين أو الفلاش ' ------------------------------------------------------------ ' تمييز الخلايا التى بها اخطاء بالتعديل ' For Each C In Sheets("Sheet1").Range("A2:F20") ' If IsError(C.Value) Then ' C.Value = "معادلة خاطئة" ' End If ' Next C '------------------------------------------------------------- ' تمييز الخلايا التى بها اخطاء بالتفريغ ' For Each C In Sheets("Sheet1").Range("A2:F20") ' If IsError(C.Value) Then ' C.Value = "" ' End If ' Next C '------------------------------------------------------------- ' تمييز الخلايا التى بها اخطاء بالتلوين ' For Each C In Sheets("Sheet1").Range("A2:F20") ' If IsError(C.Value) Then ' C.Interior.ColorIndex = 3 ' End If ' Next C '------------------------------------------------------------- ' تمييز الخلايا التى بها اخطاء بالفلاش For Each C In Sheets("Sheet1").Range("A2:F20") If IsError(C.Value) Then C.Select With C For i = 1 To 2 ' عدد مرات الوميض Application.Wait (Now + TimeValue("0:00:01")) ' انتظار مؤقت لمدة ثانية .Interior.ColorIndex = 6 Application.Wait (Now + TimeValue("0:00:01")) .Interior.ColorIndex = 7 Next .Interior.ColorIndex = xlNone .Font.Color = -16777024 End With End If Next '------------------------------------------------------------ End If End Sub تفضلوا المرفق وتقبلوا تحياتى select all cells if contains Error value .rar

جرب التعديل بهذا الشكل Function CalcString(S As String) Dim ArrLetters, ArrValues, X() As Byte, SpaceCounter As Long Dim I As Long, Counter As Long, Pos& ArrLetters = Join(Array("أ", "ا", "إ", "ب", "ت", "ث", "ج", "ح", "خ", "د", "ذ", "ر", "ز", "س", "ش", "ص", "ض", "ط", "ظ", "ع", "غ", "ف", "ق", "ك", "ل", "م", "ن", "ه", "ة", "و", "ي")) ArrValues = Array(1, 1, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 26, 27, 28) X = StrConv(S, vbFromUnicode) For I = 0 To UBound(X) Pos = InStr(ArrLetters, Chr(X(I))) If Pos > 0 Then Counter = Counter + ArrValues((Pos - 1) / 2) Next I On Error Resume Next SpaceCounter = SpaceCount(S) If SpaceCounter = 0 Then CalcString = Counter Else CalcString = Counter - SpaceCounter End If End Function Function SpaceCount(ByVal strLine As String) As String Dim Str As String Dim TempCount As Long Dim I As Long Str = Trim(strLine) TempCount = 0 For I = 1 To Len(Str) If Mid(Str, I, 1) = " " Then TempCount = TempCount + 1 Else If TempCount > 0 Then SpaceCount = SpaceCount & " " & TempCount TempCount = 0 End If End If Next I SpaceCount = Mid(SpaceCount, 2) End Function

أخي الكريم محمدجرب تغير السطر بهذا الشكل If Sheets(i).Name <> ActiveSheet.Name And Sheets(i).Name <> "المحاسب" Then جرب الكود بهذا الشكل النهائي Private Sub CommandButton1_Click() Dim I As Long, N As Long, R As Long Range("C13:E41").ClearContents For I = 1 To Sheets.Count If Sheets(I).Name <> ActiveSheet.Name And Sheets(I).Name <> "المحاسب" And Sheets(I).Name <> "احصاء العمر" Then N = Sheets(I).Range("C12").End(xlDown).Row For R = 13 To N If Sheets(I).Cells(R, 4) = [D5] Then With Columns(3).Rows(41).End(xlUp) .Offset(1, 0) = Sheets(I).Cells(R, 3) .Offset(1, 1) = Sheets(I).Cells(R, 4) .Offset(1, 2) = Sheets(I).Cells(R, 5) End With End If Next End If Next End Sub

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

السلام عليكم تكملة و اثراء لهدا الموضوع لقد كتبت الكود التالي الدي يعرض رسالة على فترات زمنية متقطعة بدون اللجوء الى اليوزرفورم و بدون امكانية الغائها من طرف المستخدم كما هو مطلوب أعلاه Private Sub ShowUpdatingMessage( _ ByVal Message As String, _ ByVal Title As String, _ ByVal HowManyTimes As Single, _ Optional ByVal MessageDelay As Single, _ Optional ByVal TOPMOST As Boolean, _ Optional ByVal TextColor As Long, _ Optional ByVal BackColor As Long) ال Routine اعلاه تعطي المستخدم مرونة اختيار موضوع الرسالة و عدد المرات التي سيتم فيها عرضها و مدة كل رسالة و ال Z order لنافدة الرسالة و لون الحروف و لون الخلفية طبعا لو نص الرسالة طويل فعلى مستعمل الكود أن يغير طول و عرض (WIDTH and HEIGHT Constantes) النافدة لاستعاب كل النص مرة أخرى نظرا لكتابة الكود على الويندوز 32 بت فانه لن يعمل على اويندوز و الأوفيس 64 بت لقطة من الشاشة: ملف للتحميل : https://app.box.com/s/vk5xn38vlqzik7lmts8m4q2svloix525 الكود في موديول عادي : Option Explicit Private Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type Private Type LOGBRUSH lbStyle As Long lbColor As Long lbHatch As Long End Type Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hwndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long Declare Function CreateBrushIndirect Lib "gdi32" (lpLogBrush As LOGBRUSH) As Long Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As Long Private Declare Function SetWindowText Lib "user32" Alias "SetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String) As Long Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long Private Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long Private Const WS_CHILD = &H40000000 Private Const WS_CLIPCHILDREN = &H2000000 Private Const WS_CAPTION = &HC00000 Private Const WS_EX_TOPMOST = &H8& Private Const SW_NORMAL = 1 Private Const TRANSPARENT = 1 Private Const SM_CXSCREEN = 0 Private Const SM_CYSCREEN = 1 Private Const COLOR_BTNFACE = 15 Private bWindowExist As Boolean Public Sub Test() If Not bWindowExist Then Call ShowUpdatingMessage( _ Message:="Showing message number : ", _ Title:="Officena", _ HowManyTimes:=10, MessageDelay:=1, _ TOPMOST:=True, TextColor:=vbRed, BackColor:=vbYellow _ ) End If End Sub Private Sub ShowUpdatingMessage( _ ByVal Message As String, _ ByVal Title As String, _ ByVal HowManyTimes As Single, _ Optional ByVal MessageDelay As Single, _ Optional ByVal TOPMOST As Boolean, _ Optional ByVal TextColor As Long, _ Optional ByVal BackColor As Long) Const WIDTH = 250 Const HEIGHT = 120 Dim tRect As RECT Dim tLb As LOGBRUSH Dim t As Single Dim hBrush As Long Dim hwndChild As Long Dim hwndParent As Long Dim hdc As Long Dim iCounter As Integer On Error GoTo CleanUp ' Application.EnableCancelKey = xlErrorHandler hwndParent = CreateWindowEx(IIf(TOPMOST, WS_EX_TOPMOST, 0), "BUTTON", Title, WS_CAPTION + WS_CLIPCHILDREN, _ (GetSystemMetrics(SM_CXSCREEN) - WIDTH) / 2.2, (GetSystemMetrics(SM_CYSCREEN) - HEIGHT) / 2, WIDTH, HEIGHT, 0, ByVal 0&, 0, ByVal 0&) hwndChild = CreateWindowEx(0, "STATIC", vbNullString, WS_CHILD, 0, 0, WIDTH, HEIGHT, hwndParent, ByVal 0&, Application.hInstance, ByVal 0&) If hwndChild Then bWindowExist = True Application.OnKey "%{F4}", "" ShowWindow hwndParent, SW_NORMAL ShowWindow hwndChild, SW_NORMAL DoEvents hdc = GetDC(hwndChild) SetBkMode hdc, TRANSPARENT If TextColor <> 0 Then SetTextColor hdc, TextColor End If SetRect tRect, 0, 0, WIDTH, HEIGHT tLb.lbColor = IIf(BackColor = 0, GetSysColor(COLOR_BTNFACE), BackColor) hBrush = CreateBrushIndirect(tLb) For iCounter = 1 To HowManyTimes FillRect hdc, tRect, hBrush TextOut hdc, 30, 20, Message, Len(Message) TextOut hdc, 115, 50, CStr(iCounter), Len(CStr(iCounter)) t = Timer Do DoEvents Loop Until Timer - t >= IIf(MessageDelay = 0, 1, MessageDelay) Next End If CleanUp: ReleaseDC hwndChild, 0 DeleteObject hBrush DestroyWindow hwndChild DestroyWindow hwndParent bWindowExist = False Application.OnKey "%{F4}" End Sub

حبيبى الغالى أ / ياسر خليل أنا مقدرش أزعل منك أبدا بس أنا رديت بسرعة على الموضوع تقبل خالص تحياتى وتقديرى مرفق الملف مع فتح محرر الأكواد ويوجد مثال لأسماء مكررة للتجربه فصل المكرر.zip

اخي محمد الخازمي ارجو ان يكون المرفق هو المطلوب تحياتي جلب بيانات من اكثر من شيت.rar

إذن تفضّل أستاذي القدير ياسر خليل أبو البراء : تحية خاصة.rar

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

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

بسم الله الرحمن الرحيم الساده الزملاء السلام عليكم ورحمته الله وبركاته رغم عدم تخصصى فى مجال الشيت كنترول الخاص بالمدارس ألا أنه ومن خلال موضوع شيت كنترول النقل لجميع مراحل التعليم الفني للقديرالفاضل أخى الاستاذ محمد على عبدالكريم " أبو براء " الذى كان له الفضل بعد المولى العلى القدير فى ادراك كافة مايتعلق بموضوع الشيت كنترول وخاصة بعد تجربة هذا البرنامج الفريد عمليا فقد جاءت جميع نتائجة وأومره سليمة 100% محتسبا هذا العمل فى موازين حسناته فأحببت أن أتقدم لسيادته ولجميع الساده الزملاء المهتمين بهذا الموضوع والى حضراتكم هذا المرفق وهو عباره عن فوروم يمكنك التنقل من خلاله بين أوراق العمل دون إضهار باقى الاوراق أرجو من الله تعالى أن يكون فيه النفع للجميع جزاكم الله خيرا ... تقبلوا جميعا وافر احترامى وللموضوع بقيه بحول الله تعالى

اخي abo jana14 ارجو ان يكون هذا مظلوبك وضع هذا العمل وغيره من اعمال الاخ الفاضل عبد الفتاح كيره في ميزان حسناته واعاده الله الينا سالما تحياتي كيماس1.rar

اخي سليم حاصبيا اثريت الموضوع بملفك واشدد علي يداك للتمكن من المعادلات تحياتي

اخي عبد العزيز البسكري انا لا اريد ان اثبت او ان اضيف فبالفعل هذا موجود اخي ياسر خليل أبو البراء دائما تسرق الكلمة من علي لساني فتسبقني قبل ان ارد زي ما بيقولوا القلوب عند بعضها عموما هذا ليس الا للتذكرة السريعة لملاحظتي في عدة مشاركات ليس الا فانا لايهمني ابدا عمل برنامج كامل بل بالعكس عندما يكون الرد علي سؤال مركز تستطيع الاجابة عليه بالشكل الوافي مما يجعل الاستفادة منه عالية بعكس البرنامج ولا انتم مش معايا؟ تحياتي

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

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

أخي واستاذنا الأستاذ/ مجدي يونس بارك الله فيك وجزاك خيرا علي مروركم الطيب ودعائكم لنا بصلاح الحال ورحم الله اخينا الحسامي الذي رحل عن دنيانا لكنه باقي باعماله الطيبة اللهم تكن له صدقة ورحم الله اموتنا واحياءنا جمعيا تقبل تحياتي أخي الحبيب وصديقي الصدوق مبدع اوفيسنا شوقي ربيع السلام عليكم ورحمة الله وبركاته بارك الله فيك وجزاك خيرا وكل عام وانتم بخير تقبل تحياتي اخي الحبيب الأستاذ قنديل الصياد وحشتنا والله كل عام وانتم بخير بارك الله فيك وجزاك خيرا مروركم اسعدني وشرفني تقبل تحياتي اخي الفاضل م/ ياسر فتحي السلام عليكم ورحمة الله وبركاته بارك الله فيك وجزاك خيرا علي مرورك ودعائك الطيب وكل عام وانتم بخير تقبل تحياتي اخي الحبيب / ابوالبراء شعلة المنتدي بارك الله فيك وجزاك خيرا علي مروركم الطيب تقبل الله منا ومنكم صالح الاعمال وكل عام وانتم بخير مع تحياتي

السلام عليكم أستاذنا المحترم سليم ...معادلة ناجحة وممتازة...جزاكم الله خيراً.. تنويه: على من يريد استخدام الدالة استخدام الفاصلة المنقوطة حسب إعدادات الجهاز لديه ...لتعمل بنجاح... نشكرك أستاذنا الكريم ...ونودّ أن يقوم أحد الأساتذة الأجلاء بالاستجابة لمطلب الأستاذ أسامة البراوي ...لتعم الفائدة...فمن حقنا على منتدانا أن نتعلم من أساتذته الكرام وهم لا يقصرون... والسلام عليكم.

تعديل على المعادلة كي تتجاهل الفراغات =IF(A1<>"",SUM(MATCH(MID(SUBSTITUTE(A1," ",""),ROW(INDIRECT("1:"&LEN(SUBSTITUTE(A1," ","")))),1),{"ا";"ب";"ت";"ث";"ج";"ح";"خ";"د";"ذ";"ر";"ز";"س";"ش";"ص";"ض";"ط";"ظ";"ع";"غ";"ف";"ق";"ك";"ل";"م";"ن";"ه";"و";"ي"},0)),"") استاذ اسامة اذهب الى هذا العنوان لتجد ما يهمك امره عن معادلات لصفيف https://support.office.com/ar-sa/article/إرشادات-وأمثلة-لصيغ-الصفائف-3be0c791-3f89-4644-a062-8e6e9ecee523

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

السلام عليكم ورحمة الله لست أدري إن كنت قد فهمت المطلوب... انظر الملف المرفق لعل فيه بعضه.. بن علية Book1.rar

هل هدا ما تقصده : (غير حروف الاسم ABDEL AZIZ الى العربية ) ... لاحظ أنني غيرت الكود TextOut hdc, 30, 20, Message & " " & iCounter, Len(Message & " " & iCounter) Option Explicit Private Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type Private Type LOGBRUSH lbStyle As Long lbColor As Long lbHatch As Long End Type Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hwndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long Declare Function CreateBrushIndirect Lib "gdi32" (lpLogBrush As LOGBRUSH) As Long Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As Long Private Declare Function SetWindowText Lib "user32" Alias "SetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String) As Long Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long Private Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long Private Const WS_CHILD = &H40000000 Private Const WS_CLIPCHILDREN = &H2000000 Private Const WS_CAPTION = &HC00000 Private Const WS_EX_TOPMOST = &H8& Private Const SW_NORMAL = 1 Private Const TRANSPARENT = 1 Private Const SM_CXSCREEN = 0 Private Const SM_CYSCREEN = 1 Private Const COLOR_BTNFACE = 15 Private bWindowExist As Boolean Public Sub Test() If Not bWindowExist Then Call ShowUpdatingMessage( _ Message:="ABDEL AZIZ", _ Title:="Officena", _ HowManyTimes:=10, MessageDelay:=1, _ TOPMOST:=True, TextColor:=vbRed, BackColor:=vbYellow _ ) End If End Sub Private Sub ShowUpdatingMessage( _ ByVal Message As String, _ ByVal Title As String, _ ByVal HowManyTimes As Single, _ Optional ByVal MessageDelay As Single, _ Optional ByVal TOPMOST As Boolean, _ Optional ByVal TextColor As Long, _ Optional ByVal BackColor As Long) Const WIDTH = 250 Const HEIGHT = 120 Dim tRect As RECT Dim tLb As LOGBRUSH Dim t As Single Dim hBrush As Long Dim hwndChild As Long Dim hwndParent As Long Dim hdc As Long Dim iCounter As Integer On Error GoTo CleanUp ' Application.EnableCancelKey = xlErrorHandler hwndParent = CreateWindowEx(IIf(TOPMOST, WS_EX_TOPMOST, 0), "BUTTON", Title, WS_CAPTION + WS_CLIPCHILDREN, _ (GetSystemMetrics(SM_CXSCREEN) - WIDTH) / 2.2, (GetSystemMetrics(SM_CYSCREEN) - HEIGHT) / 2, WIDTH, HEIGHT, 0, ByVal 0&, 0, ByVal 0&) hwndChild = CreateWindowEx(0, "STATIC", vbNullString, WS_CHILD, 0, 0, WIDTH, HEIGHT, hwndParent, ByVal 0&, Application.hInstance, ByVal 0&) If hwndChild Then bWindowExist = True Application.OnKey "%{F4}", "" ShowWindow hwndParent, SW_NORMAL ShowWindow hwndChild, SW_NORMAL DoEvents hdc = GetDC(hwndChild) SetBkMode hdc, TRANSPARENT If TextColor <> 0 Then SetTextColor hdc, TextColor End If SetRect tRect, 0, 0, WIDTH, HEIGHT tLb.lbColor = IIf(BackColor = 0, GetSysColor(COLOR_BTNFACE), BackColor) hBrush = CreateBrushIndirect(tLb) For iCounter = 1 To HowManyTimes FillRect hdc, tRect, hBrush TextOut hdc, 30, 20, Message & " " & iCounter, Len(Message & " " & iCounter) ' TextOut hdc, 115, 50, CStr(iCounter), Len(CStr(iCounter)) t = Timer Do DoEvents Loop Until Timer - t >= IIf(MessageDelay = 0, 1, MessageDelay) Next End If CleanUp: ReleaseDC hwndChild, 0 DeleteObject hBrush DestroyWindow hwndChild DestroyWindow hwndParent bWindowExist = False Application.OnKey "%{F4}" End Sub

السّلام عليكم و رحمة الله و بركاته بارك الله فيك أستاذنا القدير محمّد حسن المحمّد على المتابعة الجيّدة و المستمرّة لشتّى المواضيع ..جزاك الله خيرًا و زادها بميزان حسناتك فائق احتراماتي

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

أستادي الفاضل أنس كما سبق لي و ان قلت انه يصعب علي كتابة الكود المناسب على أنظمة الويندوز 64 بت لأنني أشتغل على الويندوز 32 أوفيس 2007 برمجة ال API تحديدا تتطلب التجريب و اعادة التجريب .. لقد أنشأت العديد من الأكواد في مجالات مختلفة و التي تحتاج الى تعديل لكي تشتغل على الويندوز 32 و 64 بت في نفس الوقت ... ان شاء الله خير عنما أقتني جهازا جديدا

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

السّلام عليكم و رحمة الله و بركاته لم أفهم الموضوع من أساسه .. فقط تهيّأ لي أنّه عبارة عن " باركود " .. لم أجرّب الكود و بدون أن أستعمله .. أقول لك أستاذنا الغالي و القدير ياسر خليل أبو البراء .. ما أروعك و ما أروع أكوادك .. قمّة في الدقّة و الكفاءة و الأناقة أكرّر مرة أخري أنّه في نهاية المطاف لا يمكننا إلا نرفع القبعة لك .. بارك الله فيك و جزاك الله خيرًا و زادك من علمه و فضله فائق احتراماتي

سلمت يداك استاذي عبد العزيز عمل اكثر من رائع ولكن كان طلب اخير عندما تنهي الفتره ويطلب كلمه المرور فاذا كانت خاطئه لا اريد غلق الملف لكن اريده يفتح مدي معين من صفحه واحده واخفاء الباقي تماما الي ان يتم ادخال كلمه المرور والغاء رساله التحذير

السلام عليكم ورحمة الله أخي الكريم، تم عمل المطلوب بواسطة معادلات وأعمدة مساعدة إضافية... وأترك عمل الأكواد لمن له باع في ذلك... أرجو أن تفي المعادلات بالمطلوب... بن علية استدعاء من عدة صفحات...rar

أخي الحبيب جعفر يبدو أنني سأكون مصدر إزعاج لك .. قمت بالتعديل على API Declarations لكي يعمل الكود على الويندوز 64 بت وعند التنفيذ ظهرت لي رسالة File not found : olepro32.dll أعمل على ويندوز 10 64 بت ...

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

فعلا ملفك به خلل ولا اعرف ما هو هذا الخلل ولقد حل لك الاخ العزيز hat المشكلة بتحويل الملف الى اوفيس 2003 وتعمل عليه الدالة بصورة صحيحة واليك دالة اخرى تفى بنفس الغرض =COUNTBLANK(F6:F8)

السلام عليكم ورحمة الله وبركاته الحمد لله على عودة الموقع من جديد نكمل معكم ان شاء الله ما بدأناه فىى هذا الموضوع وهو طريقة انشاء شريط ادوات بواسطة Xml وقد تعلمنا كيفية اضافة تبويب Tab جديد وكيفية اضافة المجموعات Groups الى التبويب Tab واليوم ان شاء الله نتعلم كيفية اضافة الادوات كالازار وغيرها الى التبويب كان هذا هو الكود الذى وصلنا اليه فى نهاية الموضوع السابق <customUI xmlns="http://schemas.microsoft.com/office/2006/01/customui"> <ribbon startFromScratch="false"> <tabs> <tab id="customTb" label="MY NEW TAB" visible="true"> <group id="dbGroup" label="’My Group"> </group> </tab> </tabs> </ribbon> </customUI> وهو يقوم بانشاء تبويب جديد واضافة مجموعة جديدة بداخله وكما لاحظنا فان جميع الوسمة متداخله ف ribbon بداخلها Tab ثم Group واخيرا بداخله الاوسمة الخاصة بالادوات عندما نقوم باضافة ادوات نعرف الاداة كما يلى <سمات الاداة معرف الاداة اسم الاداة/> اسم الاداة هو تحديد اذا كانت زر او خانة اختيار او قائمة منسدلة وغيرها ثم معرف الاداة وينقسم معرف الاداة الى قسمين اما معرف مايكروسوفت اوفيس او معرف خاص فالمعرف الخاص بالاوفيس هو الادوات الموجودة فى الاوفيس اصلا كالنسخ واللصق والمحاذاة وغيرها اما ان اردنا انشاء اداة خاصة بنا نستخدم معرف خاص نختاره كيفما نشاء ثم سمات الاداة وهى باختصار تشبه خصائص الاداة كالحجم والتسمية التوضيحية والصورة وغيرها وهذه اكثرها استخداما Enabled تستخدم لمعظم الادوات Visible اظهار او عدم اظهار ID/IDMso المعرف الخاص بالعنصر Image/ImageMso الصورة الخاصة بالعنصر InsertAfterMso لتحديد مكان العنصر بعد عنصر آخر InsertBeforeMso لتحديد مكانه قبل عنصر آخر Lable التسمية التوضيحية Size الحجم والآن بعد هذا الطلاع على طريقة تعريف الاداة بشكل عام دعونا نعرف تفاصيل اكثر بالتطبيق العملى <button idMso="Cut" label="My Cut Button"/> هذا هو كود انشاء زر قص Cut وكما قلت سابقا اسم الاداة button وبعد ذلك المعرف وهنا استخدمنا المعرف الخاص بالاوفيس Cut ونستخدم هذه الطريقة عندما نريد ادراج اى من الادوات الموجودة بالاوفيس والاكسيس ولمعرفة المعرف الخاص باى اداة مثلا التصدير لاكسيل افضل طريقة هى كما بالصورة نجد ان المعرف مكتوب بين قوسين وهو فى هذه الحالة ExportExcel ويجب الانتباه لحالة الاحرف <button idMso="ExportExcel" label="Export To Excel By XML" /> وكما قلنا سابقا ان هناك العديد من الخصائص او السمات التى نقوم بتمريرها للعنصر وجيمعها اختيارى ما عدا ال ID فاذا ادخلنا مثلا الكود بهذه الطريقة دون تحديد خاصية Size لهذا الزر نلاحظ ظهوره بالشكل الافتراضى الصغير وكذلك صورة الامر Cut الافتراضية وهو هكذا اذا اردنا ان تجعل حجمه يظهر بشكل كبير علينا ان نقوم باضافة السمة Size الى الكود ليصبح بهذا الشكل والخاصية size= اما normal كما فى الصورة السابقة او large كما فى الصورة التالية <button idMso="Cut" label="My Cut Button" Size="large" /> وكذلك الخاصية Enabled <button idMso="Cut" label="My Cut Button" Size="large" enabled="false" /> واذا اردنا تغيير خاصبة Visible اخفاءالامر cut نكتب كما يلى <button idMso="Cut" visible="false" /> اما الخاصية InsertBeforeMso و insertAfterMso فتكون كالتالى <button idMso="ExportExcel" label="Export For EXC" size="large" insertBeforeMso="Cut" /> فهذا الكود يقوم بانشاء زر التصدير لاكسيل ويضعه قبل الامر Cut الذى انشاناه سابقا وان اردنا ان يضعه بعده فنغير InsertBeforeMso الى insertAfterMso وهكذا اعتقد اننا قد انتهينا من شرح اهم الخصائص فى الازرار وكيفية استخدامها وكيفية انشاء زر يقوم بمهمة مضمنة فى الاوفيس اما بالنسبة لعمل زر يقوم بتنفيذ امر مايكرو فيكون الكود هكذا <button id="Msg" label="Hello" Size="large onAction="اسم الماكرو" /> و onAction هو عبارة عن سمة نكتب بها ما يحدث عند التفاعل مع الاداة كالضغط على الزر فى هذه الحالة ويصبح الكود النهائى حتى الآن <customUI xmlns="http://schemas.microsoft.com/office/2006/01/customui"> <ribbon startFromScratch="false"> <tabs> <tab id="customTb" label="MY NEW TAB" visible="true"> <group id="dbGroup" label="’My Group"> <button idMso="Cut" label="Cut" size="large" /> <button idMso="ExportExcel" label="Export For EXC" size="large" insertBeforeMso="Cut" /> <button id="RunMacro" label="Open" size="large" imageMso="ViewsFormView" onAction="OpenForm"/> </group> </tab> </tabs> </ribbon> </customUI> وان شاء الله فى الدرس القادم نتحدث عن ربط الازرار بالماكرو والكود بتفصيل اكثر مرفق لكم القاعدة وبها ما شرحته Ribbon Customizations.rar

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

السلام عليكم ورحمة الله وبركاته الى سيادتكم موضوع فى غاية البساطه وغاية الاهمية هو كيفية اجراء نسخه احتياطيه من ملف الاكسيل تفاديا للتلف تقبلوا خالص تحياتى https://www.youtube.com/watch?v=1R_iu8Ms3kA&feature=youtu.be نسخه احتياطيه.rar

السلام عليكم جزاك الله خيرا استاذنا / عبدالله باقشير فعلا هذا أردت وقت بنقله الى ملفى وحفظت به نسخة وعند الضغط مرة أخرى ظهرت لى هذه الرسالة ماذا أفعل وجزاكم الله خيرا http://im44.gulfup.com/H114YI.bmp

تفضل اخى ومرفق صورة للكود وفية اسم الفلدر ومكان الدريف d الدريف المراد التخزين فية osama اسم الفلدر اعمل فلدر فى الدريف الذى تراة وغير الاسم فى الكود والمكان على حسب ما تراة o11.rar

السلام عليكم ورحمة الله وبركاته اطلب من الاخوة الكرام طريقة حساب عدد الايام و عدد الشهور وعدد السنوات من تاريخ التنصيب الى يومنا هذا افيس 2007 بارك الله فيكم Classeur1.rar

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

الاخ محمد مختار بعد التحية يمكنك عمل ذلك عن طريق استخدام شرطين فى التنسيق الشرطى وتحديد لون كل منهما الصيغة التالية فى الشرط الاول واختار اللون للسطور الفردية =MOD(ROW();2)=1 الصيغة التالية فى الشرط الثاتى واختار اللون للسطور الزوجية =MOD(ROW();2)=0 وتوجد اداه لادراج هذه الصيغ نيابة عنك فى الحلول الذكية واليك الرابط http://www.officena.net/ib/index.php?s=&am...ost&p=61214 شاهد المرفق Book11.rar