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

أبدأ بحمد الله أولا وأخيرا على ما انعم ووفق وأصلي واسلم على الرحمة المهداة والسراج المنير نبينا محمد وعلى آله وصحبه وسلم ... وبعد كل عام وأنتم بخير وأعاد الله علينا أيامه الكريمة بالخير واليمن والبركات في موضوع اخي الكريم ابو عبدالرحمن وطلبه لواجهة برنامج لتسجيل الأطفال لرياض الاطفال او الروضة علي هذا الرابط فضلت ان تكون في مشاركة منفصلة لتعميم الفائدة ان شاء الله تعالى بشكل بسيط وجذاب صدقة جارية لفارس من فرسان منتدانا أوفيسنا أخي ومعلمنا عماد الحسامي رحمة الله عليه ورحم جميع المسلمين وغفر لهم الأحياء منهم والأموات حتي لا أطيل عليكم شرح مبسط للبرنامج أترككم لتجربة البرنامج في المرفقات وارحب بمشاركتكم في اجراء اية تعديلات وفقنا الله واياكم للصالحات مع تحياتي // ضاحي الغريب 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

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

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

السلام عليكم و رحمة الله و بركاته الاخوة الاحباب بالمنتدى أقدم اليكم قاعدة بيانات للموارد البشرية HR الاصدار الثاني كلمة المرور : 111 و أسأل الله العلى العظيم أن ينفعكم بهذا العمل و الله الموفق والمستعان و السلام عليكم ورحمة الله و بركاته HR 3 with listbox.rar HR for Windows 8 FADILA.rar

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

السلام عليكم إخوتي خبراء إكسيل الكرام: طرح علي اﻷخ westexcel سؤالا ظنا منه أنني مهندس في مجال البرمجة وبما أنه في مجال بحركم الواسع الذي تخوضون غماره فإنني أحيل سؤاله عليكم رغبة بمساعدته. فالدال على الخير كفاعله أقدم لكم السؤال الذي طرحه..ولكنني أطلب منه فضلا لا أمرا تعريب اسمه الكريم ...ومتابعة هذا الموضوع ليقوم بإدراج الملف والبيانات التي تساعدكم ﻹيصاله إلى شط اﻷمان في هذه المسألة...وكلي رجاء أن تقدموا ما تستطيعوه ...تقبلوا تحياتي العطرة.. نص الرسالة الخاصّة كالآتي : السلام عليكم مهندس الغالي بارك الله فيك وحماك من كل شوء اريد من جنابك الكريم ان تخبرني عن طريقة استطيع وضع اكثر من 200 عدد في الخلية الواحدة ويقبل العمليات الاربع لانه الآن لا تستطيع اكثر من 12 او 15 عدد في الخلية الواحدة مثلا هذا الرقم 58969878695878 * 58968957896586 = 3477392293984013519668472508 وهكذا بارك الله فيك مقدما سيدي العزيز على تفضلك بالاجابة أتقدّم بالشكر و العرفان بالجميل الذي يقدّمه لنا دومًا أستاذنا القدير محمد حسن المحمد .. و إذا بي الآن أستلهم و أقتبس طريقته لحل معضلات السّادة الأعضاء ..بارك الله فيك سيّدي الكريم المحترم محمد حسن المحمد.. وفّقك الله و سدّد خطاك لما يحبّه و يرضاه . فائق احتراماتي

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

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

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

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

اخي الخازمي لا تتقيل ولا شئ قول ما بخاطرك كما يشرفني معرفتك اخي وسعدت برد اخي ياسر فقد كفي ووفي تحياتي

السلام عليكم شكراً للرجل القدير عادل حنفي الذي اعرفه من اعماله من تاريخ 18/2/2014 وهو لايعرفني شكراً لهذا الكود الجميل بارك الله فيك ** طبعاً رجل الاسعاف السريع الذي لايتردد في مساعدة اي شخص في المنتدى الاستاذ ياسر خليل شكراً على الحل

تعديل على المعادلة كي تتجاهل الفراغات =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

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

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

هل هدا ما تقصده : (غير حروف الاسم 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

في ال الماكرو Test بدل : Message:="Showing message number : ", بالتاي Message:="عبد العزيز : ", ربما تحتاج أيضا ضبط طول و عرض النافدة عن طريق تغيير ال WIDTH و HEIGHT Constantes الموجودة في ال ShowUpdatingMessage Routine

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

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

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

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

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

السّلام عليكم و رحمة الله و بركاته الحمد لله الذي بنعمته تتم الصالحات أخي الكريم abo jana14 كلمة المرور هي 123 بإمكانك تغييرها من كود اليوزرفورم شاهد الصورة لو سمحت : أمّا في حدث الذيس وورك بوك لو غيرت التاريخ إلى تاريخ أكبر من التاريخ الحالي فسوف لن يطلب منك كلمة المرور .. فائق احتراماتي

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

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

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

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

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

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

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

الحمد لله توصلت الى الحل Classeur1.rar

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

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

وألان نبدأ بأول الحلول الذكية أداة :: التخلص من علامات خطأ المعادلات مثل الأخطاء التالية : #DIV/0! / #N/A / #NAME? / #REF! / #NUM! / #NULL! / #VALUE! لقد تم عرض أكثر من أسلوب بالمنتدى للتخلص من هذه الأخطاء ولكن أسلوبنا هنا هو السهل الممتنع بضغطة زر واحدة يمكن التخلص من علامات الخطأ للورقة الحالية بالكامل وتعتمد الطريقة هنا على تعديل صيغة الخلية المختارة أو مجموعة الخلايا المختارة أو كل خلايا الورقة الحالية المحتوية على معادلات بأدراج أسلوب ( ISERROR ) ضمن صيغة المعادلة . وهذا كنا نقوم به يدويا لكل مجموعة خلايا بها معادلات متشابهة أو بأتسخدام دالة (IF ) أو كنا نستخدم أسلوب التنسيق الشرطي لإخفاء علامات الخطأ الظاهرة كل هذا أصبح من الماضي ألان . ألان اضغط الزر يتم تعديل جميع الصيغ على سبيل المثل إذا كانت الصيغة أو الصيغ مثل ذلك: =SUM(A1:A9) =VLOOKUP(H1;A1:F9;2;FALSE) تصبح بضغطة زر كالاتى : =IF(ISERROR(SUM(A1:A9));"";SUM(A1:A9)) =IF(ISERROR(VLOOKUP(H1;A1:F9;2;FALSE));"";VLOOKUP(H1;A1:F9;2;FALSE)) وهى تعمل مع أكثر الصيغ تعقيدا وألان كيف نعمل ذلك افتح الملف المراد التخلص من علامات خطأ المعادلات اختار الصفحة المراد تعديلها قم بتشغيل الملف الموجود بالمرفقات إذا لم يذهب بك إلى ملفك اذهب إليه اختار خلية بها صيغة معادلة أو عدة خلايا ثم اضغط (F2) لتعديلها . أو يمكن اختيار كل خلايا المحتوية على صيغ في الورقة الحالية بضغط (F1) ثم اضغط (F2) لتعديلها . أخيرا قم بحفظ الملف الخاص بك . لو تكرمت اخبرنا برأيك هل أستمر بأدراج الحلول الذكية أم لا . تحياتي لكم جميعا ملف التخلص من علامات خطأ المعادلات بالمرفقات ChangeFormulas.rar