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

السلام عليكم ورحمة الله وبركاته جزاكم الله خيراً ..وجعلكم نبراساً للعلم ومنارة لإخوانك أخي الحبيب حسام تقبل تحياتي العطرة والسلام عليكم

استاذى الفاضل / هانى بدر جرب المرفق تم عمل المطلوب الاول أما المطلوب الثانى لم أفهم قصدك جيدا يرجى مزيد من التوضيح تقبل تحياتى Rooms.zip

الأخ العزيز كريم بارك الله فيك وجزاك الله كل خير ملف جميل جداً ومتميز .. الأخ الحبيب أحمد الملف الذي أرفقه الأخ كريم عبارة عن موديول تم تصديره ليكون ملف منفصل ، ويتم استيراده بالشكل التالي : روح لمحرر الأكواد ..كليك يمين في نافذة المشروع .. اختار الأمر Import File .. حدد مكان الملف الذي أرفقه الأخ كريم بعد فك ضغطه بالطبع والذي امتداده Bas .. وأخيراً انقر الأمر Open .. ستجد أن الموديول قد أضيف في نافذة المشروع وإليك الكود الموجود بالملف بعد تنسيقه بشكل مناسب (أحب تنسيق الأكواد ليسهل التعامل معها) Private Function ChangeToDigits1(Temp As String) As String If Temp = "0" Then ChangeToDigits1 = "" GoTo Finish End If If Temp = "1" Then ChangeToDigits1 = "واحد" GoTo Finish End If If Temp = "2" Then ChangeToDigits1 = "اثنان" GoTo Finish End If If Temp = "3" Then ChangeToDigits1 = "ثلاثة" GoTo Finish End If If Temp = "4" Then ChangeToDigits1 = "أربعة" GoTo Finish End If If Temp = "5" Then ChangeToDigits1 = "خمسة" GoTo Finish End If If Temp = "6" Then ChangeToDigits1 = "ستة" GoTo Finish End If If Temp = "7" Then ChangeToDigits1 = "سبعة" GoTo Finish End If If Temp = "8" Then ChangeToDigits1 = "ثمانية" GoTo Finish End If If Temp = "9" Then ChangeToDigits1 = "تسعة" GoTo Finish End If Finish: End Function Private Function ChangeToDigits2(Temp As String) As String Dim Digit1 As String Dim Digit2 As String Dim Between As String Digit2 = Left(Temp, 1) Digit1 = Right(Temp, 1) If Digit2 = "1" Then ChangeToDigits2 = "عشر" GoTo Finish End If If Digit2 = "2" Then ChangeToDigits2 = "عشرون" GoTo Finish End If If Digit2 = "3" Then ChangeToDigits2 = "ثلاثون" GoTo Finish End If If Digit2 = "4" Then ChangeToDigits2 = "أربعون" GoTo Finish End If If Digit2 = "5" Then ChangeToDigits2 = "خمسون" GoTo Finish End If If Digit2 = "6" Then ChangeToDigits2 = "ستون" GoTo Finish End If If Digit2 = "7" Then ChangeToDigits2 = "سبعون" GoTo Finish End If If Digit2 = "8" Then ChangeToDigits2 = "ثمانون" GoTo Finish End If If Digit2 = "9" Then ChangeToDigits2 = "تسعون" GoTo Finish End If Finish: If Digit1 = "0" Then Digit1 = "" Between = "" Else If Digit2 = "1" Then Between = " " Digit1 = ChangeToDigits1(Digit1) Else Between = " و " Digit1 = ChangeToDigits1(Digit1) End If End If If Digit2 = "0" Then Between = "" ChangeToDigits2 = Digit1 & Between & ChangeToDigits2 If Temp = "00" Then ChangeToDigits2 = "" If Temp = "11" Then ChangeToDigits2 = "احدى عشر" If Temp = "12" Then ChangeToDigits2 = "اثنا عشر" If Temp = "10" Then ChangeToDigits2 = "عشرة" End Function Private Function ChangeToDigits3(Temp As String) As String Dim Between As String Dim Handred As String Dim First As String Dim Second As String Handred = " مائة" First = ChangeToDigits1(Left(Temp, 1)) Second = ChangeToDigits2(Right(Temp, 2)) If Second <> "" Then Between = " و " Else Between = "" If First = "" Then Between = "" Handred = "" End If If First = "واحد" Then First = "" If First = "اثنان" Then First = "" Handred = "مئتا" End If ChangeToDigits3 = First & Handred & Between & Second If Temp = "000" Then ChangeToDigits3 = "" End Function Private Function ChangeToDigits4(Temp As String) As String Dim Between As String Dim Thousand As String Dim First As String Dim Second As String Thousand = " آلاف" First = ChangeToDigits1(Left(Temp, 1)) Second = ChangeToDigits3(Right(Temp, 3)) If Second <> "" Then Between = " و " Else Between = "" If First = "" Then Between = "" Thousand = "" End If If First = "واحد" Then First = "" Thousand = "الف" End If If First = "اثنان" Then First = "" Thousand = "الفا" End If ChangeToDigits4 = First & Thousand & Between & Second If Temp = "0000" Then ChangeToDigits4 = "" End Function Private Function ChangeToDigits5(Temp As String) As String Dim Between As String Dim Thousand As String Dim First As String Dim Second As String Thousand = " ألف" First = ChangeToDigits2(Left(Temp, 2)) Second = ChangeToDigits3(Right(Temp, 3)) If Second <> "" Then Between = " و " Else Between = "" If First = "" Then Between = "" Thousand = "" End If If First = "واحد" Then First = "" Thousand = "ألف" End If If First = "اثنان" Then First = "" Thousand = "ألفا" End If ChangeToDigits5 = First & Thousand & Between & Second If Temp = "00000" Then ChangeToDigits5 = "" End Function Private Function ChangeToDigits6(Temp As String) As String Dim Between As String Dim Thousand As String Dim First As String Dim Second As String Thousand = " الف" First = ChangeToDigits3(Left(Temp, 3)) Second = ChangeToDigits3(Right(Temp, 3)) If Second <> "" Then Between = " و " Else Between = "" If First = "" Then Between = "" Thousand = "" End If If First = "واحد" Then First = "" Thousand = "ألف" End If If First = "اثنان" Then First = "" Thousand = "ألفا" End If ChangeToDigits6 = First & Thousand & Between & Second If Temp = "000000" Then ChangeToDigits6 = "" End Function Private Function ChangeToDigits7(Temp As String) As String Dim Between As String Dim Million As String Dim First As String Dim Second As String Million = "ملايين" First = ChangeToDigits1(Left(Temp, 1)) Second = ChangeToDigits6(Right(Temp, 6)) If Second <> "" Then Between = " و " Else Between = "" If First = "" Then Between = "" Million = "" End If If First = "واحد" Then First = "" Million = "مليون" End If If First = "اثنان" Then First = "" Million = "مليونا" End If ChangeToDigits7 = First & Million & Between & Second End Function Private Function ChangeToDigits8(Temp As String) As String Dim Between As String Dim Million As String Dim First As String Dim Second As String Million = " مليون " First = ChangeToDigits2(Left(Temp, 2)) Second = ChangeToDigits6(Right(Temp, 6)) If Second <> "" Then Between = " و " Else Between = "" If First = "" Then Between = "" Million = "" End If If First = "واحد" Then First = "" Million = " مليون " End If If First = "اثنان" Then First = "" Million = "مليونا" End If ChangeToDigits8 = First & Million & Between & Second End Function Private Function ChangeToDigits9(Temp As String) As String Dim Between As String Dim Million As String Dim First As String Dim Second As String Million = " مليون " First = ChangeToDigits3(Left(Temp, 3)) Second = ChangeToDigits6(Right(Temp, 6)) If Second <> "" Then Between = " و " Else Between = "" If First = "" Then Between = "" Million = "" End If If First = "واحد" Then First = "" Million = " مليون " End If If First = "اثنان" Then First = "" Million = "مليونا" End If ChangeToDigits9 = First & Million & Between & Second End Function Public Function ChangeThisNumber(Allnumber As String) As String Dim Temp As String Dim Backed As String Dim Backed2 As String Dim Length As Integer Dim bigCur, smallCur As String Dim intNum As String Dim FloatNum As String Dim I As Integer Dim Found As Boolean Allnumber = Trim(Allnumber) If Not IsNumeric(Allnumber) Then ChangeThisNumber = "خطأ في الإدخال" Exit Function End If I = 1 Do While I <> Len(Allnumber) + 1 If Mid(Allnumber, I, 1) <> "." Then intNum = intNum & Mid(Allnumber, I, 1) Else Found = True GoTo Float End If I = I + 1 Loop Float: If Found Then I = I + 1 Do While I <> Len(Allnumber) + 1 FloatNum = FloatNum & Mid(Allnumber, I, 1) I = I + 1 Loop End If Temp = intNum Length = Len(Temp) If Length = 1 Then Backed = ChangeToDigits1(Temp) If Length = 2 Then Backed = ChangeToDigits2(Temp) If Length = 3 Then Backed = ChangeToDigits3(Temp) If Length = 4 Then Backed = ChangeToDigits4(Temp) If Length = 5 Then Backed = ChangeToDigits5(Temp) If Length = 6 Then Backed = ChangeToDigits6(Temp) If Length = 7 Then Backed = ChangeToDigits7(Temp) If Length = 8 Then Backed = ChangeToDigits8(Temp) If Length = 9 Then Backed = ChangeToDigits9(Temp) Temp = FloatNum Length = Len(Temp) If Length = 1 Then Backed2 = ChangeToDigits1(Temp) If Length = 2 Then Backed2 = ChangeToDigits2(Temp) If Length = 3 Then Backed2 = ChangeToDigits3(Temp) If Length = 4 Then Backed2 = ChangeToDigits4(Temp) If Length = 5 Then Backed2 = ChangeToDigits5(Temp) If Length = 6 Then Backed2 = ChangeToDigits6(Temp) If Length = 7 Then Backed2 = ChangeToDigits7(Temp) If Length = 8 Then Backed2 = ChangeToDigits8(Temp) If Length = 9 Then Backed2 = ChangeToDigits9(Temp) smallCur = StrSmallNameCurrency bigCur = StrLargeNameCurrency Dim Filse As String Dim Between As String Dim JD As String Between = " و " If Backed <> "" Then JD = " " & bigCur & " " Else JD = "" Between = "" End If If Backed2 <> "" Then Filse = " " & smallCur & " " Else Filse = "" Between = "" End If ChangeThisNumber = Backed & JD & Between & Backed2 & Filse End Function استخدام الدالة المعرفة ضع رقم في الخلية A1 وفي الخلية B1 ضع المعادلة التالية =ChangeThisNumber(A1) وإليك الملف المرفق مطبق فيه الدالة المعرفة .. تقبل وافر تقديري واحترامي Spell Number UDF Function Karim.rar

الحمد لله الذي بنعمته تتم الصالحات وجزيت خيراً بمثل ما دعوت لي وزيادة أخي العزيز أحمد تقبل تحياتي

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

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

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

استاذى الحبيب / هانى بدر جرب المرفق التالى ان شاء الله هو طلبك تم العمل بكود اخر طبقا للملف المرفق فى المشاركة الاولى لحضرتك سوف يتم اظهار الفريمات طبقا لعدد الاسطر وسوف يتم التمييز باللون لكل ليبل حسب المحتوى كما طلبت وسوف يظهر عنوان عند وضع مؤشر الماوس على اى لليبل ويمكن حضرتك تعمل اى كود عند الضغط على اى ليبل فى حل اخر براسى ممكن اعمله ان شاء الله واذا توصلت لشئ سوف ارفق الملف لحضرتك تقبل تحياتى Rooms - 2.zip

السلام عليكم شكرا لك أخي ياسر , ( صاحب الهمة الذي يسعى دائما للوصول إلى القمة ) أخي العزيز عندما دخلت على هذا الموضوع وجدت ألاخ على المصري قد أرسل صرخات استغاثه ولم أجد من يرمي له بطوق النجاة أرسل ثلاث صرخات ( للرفع , للرفع , للرفع ) فلم أجد بدا من رمي طوق النجاة له حتى إذا وصل إلى بر الأمان (بحمدالله) يكون بعد ذلك التفاهم معه ويكون الشرح والتفصيل إذا ما سبحت فلا توغلن *** فإن السلامة في الساحل وإما سقطت على بيدر *** فحوصل من السنبل الحاصل والحمدلله فقد حصل الأخ على المصري الأن على ثلاثة أطواق للنجاة أبوعيد , أحمد الفلاحجي , ياسر خليل ولم تذهب صرخاته سدى وبما أني معلم للرياضيات في الثانويةالعامة فقد جذبتني صرخاته فقمت بهذا الإسعاف الأولي ولست متأكدا هل يلبي طلب أخينا علي أم لا ============== الملف به مجموعة من الاختبارات لنفس الطلاب وكل ورقة بها اختبار يختلف عن الورقة الأخرى (أي الاختبار الآخر ) أنا فقط قمت بجمع النتائج لجميع الاختبارات في صفحة واحدة ( كما فهمت من طلبه ) تحياتي للجميع

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

زين شاشة برنامجك بعلم دولتك واجعلة يرفرفر خفاقا" مرفق مثال بسيط flags.rar

أخي الكريم محمود جرب الكود التالي عله يكون المطلوب ... Private Sub CommandButton1_Click() Dim Coll As New Collection, arrData, arrOut, arrStrSheet, strSheet, arrBlank, arrTemp Dim I As Long, J As Long, K As Long, strKey As String arrStrSheet = Array("المشتروات", "المبيعات") ReDim arrBlank(0 To 4) For K = LBound(arrStrSheet) To UBound(arrStrSheet) With Sheets(arrStrSheet(K)) arrData = .Range("C6:E" & Application.Max(.Cells(.Rows.Count, "C").End(xlUp).Row, .Range("C6").Row)).Value On Error Resume Next For I = 1 To UBound(arrData, 1) strKey = Trim$(arrData(I, 1) & Chr$(2) & arrData(I, 2)) arrTemp = arrBlank arrTemp = Coll(strKey) arrTemp(0) = arrData(I, 1) arrTemp(1) = arrData(I, 2) arrTemp(K + 2) = arrTemp(K + 2) + arrData(I, 3) Coll.Remove strKey Coll.Add Key:=strKey, Item:=arrTemp Next I On Error GoTo 0 End With Next K ReDim arrOut(1 To Coll.Count, 1 To 5) I = 0 For Each arrTemp In Coll I = I + 1 For J = 0 To 3 arrOut(I, J + 1) = arrTemp(J) Next J arrOut(I, 5) = arrOut(I, 3) - arrOut(I, 4) Next arrTemp With Sheets("جرد البضاعة").Range("B5") .CurrentRegion.Offset(1, 1).ClearContents If Coll.Count Then With .Offset(1, 1).Resize(UBound(arrOut, 1), UBound(arrOut, 2)) .Value = arrOut .Sort Key1:=.Columns(1), Order1:=xlAscending, Key2:=.Columns(2), Order2:=xlAscending, Header:=xlNo End With End If End With End Sub وإليك الملف المرفق فيه تطبيق الكود تقبل تحياتي Transfer Purchases & Sales Using Arrays.rar

أخى الفاضل / خالد الرشيدى عندك حق يظهر إن الزهايمر اشتغل تانى هذا السطر لم يعد له أهمية فى الكود وفعلا نسيت حذفه بعد الانتهاء من الشكل النهائى للكود ربنا يستر على الذاكره جزاك الله كل خير ودا الشكل النهائى للكود بعد حذف السطر Sub ragab() Dim x As Integer Dim T As Variant Dim S_name As Range '============================================================= For Each T In Array("عام", "خاص", "مغلق", "مفتوح") On Error Resume Next With Sheets(T) Set S_name = .Columns(2).Find(What:=[d5], LookAt:=xlWhole) x = Application.WorksheetFunction.Match(T, [c8:c11], 0) + 7 .Cells(S_name.Row, 3) = Cells(x, 4) End With Next End Sub

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

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

وجزيت خيراً بمثل ما دعوت وزيادة أخي وحبيبي أبو بسملة التنوع في الحلول يثري الموضوعات بشكل كبير تقبل تحياتي

انا لا اقصد الاهانة ..و لكن ايصالك للفكرة معقد جدا... ............خطوة بخطوة هل تقصد : 1- لديك جدول العمال 2- لديك جدول الايام المكونة لشهر واحد ...30 يوم/31 يوم حسب الشهر 3- لديك جدول الحضور ....(حاضر / غائب 4- ان العامل يتقاضى راتبه على شكل عمل يومي.....و اذا حدث و ان غاب 3 ايام متتالية يخصم منه راتب يوم واحد....مثلا في شهر جانفي المكون من 31 يوم غاب 3 ايام متتالية يدفع له اجر 30 يوم فقط 5- اذا حدث و ان غاب 4 ايام متتالية في الشهر يفصل العامل 6- اذا غاب العامل 3 ايام و لكن غير متتالية .....تحسب ايضا على انها غياب ليوم واحد و يتم خصم راتبه (كنفس النقطة رقم 4... هل هذا ما تعنيه ؟؟؟؟

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

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

السلام عليكم تحت أمرك ولوتكرمت ترفع آخر ملف تريد استكماله

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

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

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

أخي الكريم أحمد الملف منذ أمد بعيد .. منذ بداياتي في الإكسيل .. نعرف إنه مش موجود عندي في مكتبتي الخاصة (جزاكم الله خيراً على الهدية) قم بوضع المعادلة التالية في الخلية Q2 =C2 وفي الخلية Q3 ضع معادلة الصفيف التالية (يتم الضغط على Ctrl + Shift + Enter بعد إدخال المعادلة) =IF(Q2="","",INDEX(C3:C$14,MIN(IF(COUNTIF(Q$2:Q2,C3:C$13),ROW(A$14)-ROW()+1,ROW(C3:C$13)-ROW()+1)))) ثم قم بسحب المعادلة إلى آخر خلية Q13 ستظهر في النتائج أصفار للتخلص منها قم بتحديد العمود Q بالكامل ثم كليك يمين ثم Format Cells ثم اختر الأمر Custom واكتب في الصندوق المسمى Type 0;-0;;@ ... قم بالدخول إلى التبويب Formulas ثم Name Manager ثم انقر الأمر New ثم اكتب اسم للنطاق وليكن UniqueList واكتب المعادلة التالية : =OFFSET(السجل!$Q$2,,,SUM(--(السجل!$Q$2:$Q$13<>0))) أخيراً روح للتبويب Data ثم Data Validation واختر List ثم في الحقل المسمى Source اضغط F3 من لوحة المفاتيح لتظهر لك النطاقات المسماة ..اختر منها النطاق UniqueList .. أرجو أن تكون الخطوات واضحة تقبل تحياتي

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

انا ذكرت لك وجوب استبعاد الحقول ذات القيم المتباينة وفي حال ان الحاجة تدعو الى ادراج هذه الحقول فيمكن في مسألتنا هذه استخدام القيمة last للحقول الاخرى لا حظ انه يمكننا ايضا استخدم last لحقل التاريخ بينما العكس غير صحيح للحقلين الآخرين test3.rar

اختر في حقل التاريخ القيمة max بدلا من group by ايضا لا بد من استبعاد الحقول التي يوجد فيها قيم متباينة ويمكنك جلب التاريخ الاحدث باستخدام الدالة Dmax بمعلومية المعرف مثلا

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

جزيتم خيراً إخواني الكرام على مروركم العطر بالموضوع إليكم الكود الثالث في المشاركة الأولى Sub sRange_Move() With Sheet2 .Range("A9:C12").ClearContents .Range("A9:C12").Value = Sheet1.Range("A9:C12").Value End With MsgBox "تم الترحيل بنجاح", 64 End Sub تقبلوا تحياتي Transfer Data YasserKhalil.rar

هناك كود وجدته في مدونة التميز للشروحات.. و هو يقوم بتحويل الارقام الى نص عربي عن طريق خاصية change this number كود تحويل الرقم الى نص عربي.rar

السلام عليكم أخي محمود هذا حل بمعادلات الصفيف تفضل ترحيل المشتريات و المبيعات1.rar

السلام عليكم أخي عبدالله المسميات العربية نوعين: 1. اسماء الحقول والكائنات ، ومنها اسم افتراضي له امر1 ، وعند اضافة مربع نص يقوم بتسمية افتراضيا نص1 ، وليس عندي جواب لهذه الجزئية 2. واليك المثال التالي: الاسم مكتوب بالعربي ، وانا سأجعل ارتفاع هذا القسم اطول (القسم باللون الازرق) ، مستخدما الطريقة التقليدية في التسمية: . فيصبح الكود: Private Sub راس_التقرير_Format(Cancel As Integer, FormatCount As Integer) Me.راس_التقرير.Height = Me.Height + (2 * 1440) End Sub واليك التقرير التالي ، وهو نسخة طبق الاصل من التقرير السابق: . إلا اني لم اهتم بالمسميات العربية ، وانما استعملت اسماء فهرست الكائنات في التقرير ، فاصبح الكود: Private Sub Report_Open(Cancel As Integer) Me.Section(acHeader).Height = Me.Section(acHeader).Height + (2 * 1440) End Sub والنتيجة: . فقصدي هنا اننا يمكن ان نعالج جزء من المشكلة بهذه الطريقة جعفر 291.English_wordings.mdb.zip

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

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

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

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

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

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

السلام عليكم جبنا لكم الغداء ...تفضلوا قسموهن وبعدين جهزوهن.

السلام عليكم أعزكم الله ونفع بعلمكم ...كرام النفوس أنتم إخوتي ..أرجو الله أن يجمعنا في مستقر رحمته من غير ضراء مضرة ولا فتنة مضلة والسلام عليكم.

السلام عليكم ورحمة الله وبركاته ملف ماتع وجميل وفوق الوصف تقبل تحياتي

أخي الكريم سامح طاهر هلا غيرت اسم الظهور للغة العربية ليعبر عن شخصكم الكريم جرب الكود التالي عله يفي بالغرض .. سيتم وضع معادلات في الخلية E1 والخلية F1 في الملفات المغلقة كما سيتم إخفاء العمودين C و D .. يمكنك التعديل بما يتناسب مع ملفك (ولا تطلب التعديل طالما أنك لم ترفق ملف من البداية .. طبعاً بهزر معاك .. ) ولكن للأسف الموضوعات التي لا يتم إرفاق ملف فيها غالباً ما يتم فيه تقديم مشاركات كثيرة حتى نصل للمطلوب وستلاحظ ذلك بنفسك ..بخلاف الموضوعات التي يكون فيها ملف مرفق Sub LoopThroughClosedWBs() Dim WBK As Workbook Dim FolderPath As String Dim FileName As String Dim Counter As Double FolderPath = ThisWorkbook.Path & "\" FileName = Dir(FolderPath & "*.xl*") Application.ScreenUpdating = False Application.Calculation = xlManual Do While FileName <> "" If FileName <> ThisWorkbook.Name Then Set WBK = Workbooks.Open(FolderPath & FileName) With WBK.Sheets("Sheet1") .Range("E1").Formula = "=SUM(A1:B1)" .Range("F1").Formula = "=A1*B1" .Columns("C:D").Hidden = True End With WBK.Close SaveChanges:=True End If FileName = Dir() Loop Application.Calculation = xlAutomatic Application.ScreenUpdating = True MsgBox "Finished ...", 64 End Sub وإليك الملف المرفق من عندي تقبل تحياتي Loop Through Closed Workbooks & Type Formulas And Hide Columns YasserKhalil.rar

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

يمكنك التواصل http://www.elfouadsoft.com/

أخي الكريم كيرلس بارك الله فيك على استجابتك لمطلبي بتغيير اسم الظهور باركك الرب المقدس .. تقبل تحياتي

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

تفضل اخي الكريم وإذا اضفت حقل dept بعد حقل الاسم وتريد ان يظهر الادارة تلقائيا مع اختيار رقم الموظف اذهب إلى وضع التصميم للنموذج الفرعي وفي حدث بعد التحديث لرقم الموظف اضف السطر التالي Me.USER_NAME = Me.USER_ID.Column(2) New Microsoft Office Access 2007 Database.rar

يوجد اكثر من طريقة لحذف السجلات المكررة 1- انشاء استعلام البحث عن المتطابقات بواسطة المعالج ثم حذف السجلات المكررة يدويا وهذا يصلح اذا كانت المكررات قليلة 2- نسخ بنية الجدول فقط وحفظها باسم جديد ثم تعيين احد الحقول المناسبة كمفتاح لا يقبل التكرار بعد ذلك فتح الجدول الاساس ونحدد جميع السجلات ثم ننسخها ونلصقها في الجدول الجديد النتيجة : نقل البيانات بلا مكررات ويمكن بدلا من النسخ واللصق استخدام استعلام الالحاق لعمل ذلك ملحوظة : ستخرج عليك رسائل تفيد بتعذر اللصق بسبب مخالفات وكل ما عليك هو تجاهلها بالتوفيق ،،،

كود لعرض معلومات عن الملف الذى تعمل عليه Sub ShowFolderSize(filespec) Dim fs, F, S Set fs = CreateObject("Scripting.FileSystemObject") Set F = fs.GetFile("E:\Bids.xls") S = "File Name :" & UCase(F.Name) & vbLf & _ "Total Size: " & FormatNumber(F.Size) & " Kbytes" & vbLf & _ "Created :" & F.DateCreated & vbLf & _ "Modifide :" & F.DateLastModified & vbLf & _ "Last Accessed: " & F.DateLastAccessed MsgBox S, 0, "File Size Info" Open "Log.log" For Append As #2 'Open file Print #2, S Close #2 'Close Exit Sub 'Exit End Sub ' Sub GetII() ' ShowFolderSize (filespec) ' End Sub

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