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

جرب For Each s In chose.ItemsSelected comment = comment & chose.ItemData(s) & vbCrLf chose.Selected(s) = False Next

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

إنني وقعت في نفس الذي وقعت فيه أنت سابقا حينما اجبت عن السؤال و قلت لك يومها ان الاخ الزباري يريدها عن طريق Loop كما تدين تدان الحل الجميل و الذي اعجبني هو عن طريق Array

بالاضافة الى حل الاخ ابو حنين (For Next) حلين اخرين 1-بواسطة Loop 2-بواسطة Array for VBA lovers Two In One.rar

حل ممتاز لكن الاخ الزباري يريدها عن طريق Loop

السلام عليكم ورحمة الله وبركاته كل عام وانتم بخير اطلب المسامحة ممن راسلني ولم يجد رد مني هديتي لكم بعد هذه الغيبة Option Explicit '========================================================" ' بسم الله الرحمن الرحيم " '========================================================" ' (دالة تحويل الرقم الى نص باللغة العربية (تفقيط " ' kh_TextNum " '========================================================" 'Num الرقم " '========================================================" 'sex جنس العملة " 'FALSE ( فارغ او صفر مذكر ) " 'TRUE ( أو اي رقم غير الصفر مؤنث ) " '========================================================" 'sNameCurr اسم العملة الرئيسية مفرد " 'pNameCurr اسم العملة الرئيسية جمع " 'NameCurrDec اسم العملة الكسرية " 'Decimal_Count طول الكسر افتراضـياً : بدون اظهار الكسر " '===============================================================================================================================================" 'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" '===============================================================================================================================================" ' ملاحظات ' (اولاً : العملة الرئيسية مثنى (يقوم بها الكود تلقائيا ' مع ملاحظة اذا اسم العملة ينتهي بالتاء المربوطة ' يجب ان يكتب كذلك وليس بالهاء ' ----------------------- ' ثانياً : اذا كانت العملة الرئيسية مفرد فارغاً تعتبر ' اسماء العملات (الجمع والكسري) فارغة تلقائيا ' ----------------------- 'ثالثاً : الكلمة الابتدائية بامكانك تغييرها او تجعلها فارغة Private Const MyBegTx As String = "فقط " ' "" ' ----------------------- ' MyTNum رابعا : يمكنك التغيير (اضافة,حذف,تحرير) في الثابت ' للفئات الصفرية للرقم ادناه Private Const MyTNum As String = "ألف-آلاف/مليون-ملايين/مليار-مليارات/بليون-بلايين/بليار-بليارات/ترليون-ترليونات/تريليار-تريليارات/كدرليون-كدرليونات" '===============================================================================================================================================" 'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" '===============================================================================================================================================" Function kh_TextNum(Num As String, Optional sex As Boolean = False, Optional sNameCurr As String = "", Optional pNameCurr As String = "", Optional NameCurrDec As String = "", Optional Decimal_Count As Byte = 2) As String Dim Spp, zt Dim i%, ii%, pr% Dim MyMid$, nCurr$, Txt$, Txt1$, Txt2$ '====================================== If Not IsNumeric(Num) Then GoTo kh_Exit Spp = Split("/" & MyTNum, "/") ii = UBound(Spp) If Num < 0 Then Num = Abs(Num) '====================================== If Val(Num) > Val(String((ii + 1) * 3, "9") & ".999") Then GoTo kh_Exit '====================================== nCurr = sNameCurr & "-" & IIf(pNameCurr = "", sNameCurr, IIf(sNameCurr = "", "", pNameCurr)) '====================================== Txt1 = Format(Num, String((ii + 1) * 3, "0") & ".000") For i = 0 To ii MyMid = Mid(Txt1, (i * 3) + 1, 3) If MyMid Then zt = Mid(Txt1, (i * 3) + 4, Len(Txt1)) zt = IIf(ii - i, Int(zt), zt) Txt2 = IIf(ii - i, Trim(Spp(ii - i)), nCurr) pr = 1 + IIf(ii - i, 1, CInt(sex)) Txt = Txt & IIf(Len(Txt), " و", "") & kh_nText(MyMid, Txt2, pr, zt, CBool(sNameCurr <> "")) End If If i = ii Then If MyMid = 0 Then Txt = Txt & IIf(Len(Txt), " ", "صفر ") & sNameCurr Next '====================================== Txt = MyBegTx & Txt & kh_dText(Num, sNameCurr, NameCurrDec, Decimal_Count) '====================================== kh_Exit: kh_TextNum = Trim(Txt) End Function ' معالجة العدد من 1 الى 999 لكل فئات الرقم Private Function kh_nText(ByVal iNum As String, ByVal oMm As String, ByVal ibs As Integer, ByVal z As Boolean, ByVal tCu As Boolean) As String Dim Sp Dim Num1%, Num2%, Num3% Dim oM$, S$, S1$, nT$, nT0$, nT1$, nT2$ '====================================== Sp = Split("واحد,إحدى,اثنتان,ثلاث,أربع,خمس,ست,سبع,ثمان,تسع,عشر,إحدى ,اثنتا ", ",") '====================================== If ibs Then S = "ة": Sp(1) = Sp(0): Sp(2) = "اثنان": Sp(11) = "أحد ": Sp(12) = "اثنا " Else S1 = "ة" oM = Trim(Split(oMm, "-")(0)) '====================================== Num1 = Left(iNum, 1) Num2 = Right(iNum, 2) Select Case Num1 Case 1: nT0 = "مائة" Case 2: nT0 = "مائتا" & IIf(ibs = 2, IIf(Num2 < 3, "", "ن"), IIf(Num2 = 0 And oM <> "", "", "ن")) Case 3 To 9: nT0 = Sp(Num1) & "مائة" End Select '========================================= Num1 = Right(iNum, 2) Select Case Num1 Case 1, 2: If nT0 <> "" Then If ibs = 2 Then nT0 = nT0 & " " & oM Case 11 To 99: If oM <> "" Then If ibs Then If z Then oM = oM & "اً" End Select '----------------------------------------- Select Case Num1 Case 1 nT = IIf(oM = "", Sp(0) & S1, oM) oM = IIf(ibs <> 2 And oM <> "", Sp(0) & S1, "") Case 2 nT = IIf(oM = "", Sp(Num1), Replace(oM, "ة", "ت") & IIf(z = 0 And ibs = 2 And tCu, "ا", "ان")) oM = IIf(ibs <> 2 And oM <> "", Sp(Num1), "") Case 3 To 10 oM = Trim(Split(oMm, "-")(1)) nT = Sp(Num1) & S Case 11, 12 nT = Sp(Num1) & Sp(10) & S1 Case 13 To 19 nT = Sp(Num1 - 10) & S & " " & Sp(10) & S1 Case 20 To 99 Num2 = Right(Num1, 1) Num3 = Left(Num1, 1) If Num3 = 2 Then nT1 = "عشرون" Else nT1 = Sp(Num3) & "ون" nT2 = Sp(Num2) & IIf(Num2 > 2, S, "") & " و" & nT1 If Num2 = 0 Then nT2 = nT1 nT = nT2 End Select '====================================== S = IIf(nT = "" Or iNum < 100, "", " و") nT = Replace(nT, Sp(8) & "ة", Sp(8) & "ية") kh_nText = Trim(nT0 & S & nT & " " & oM) '====================================== End Function ' معالجة الكسر Private Function kh_dText(ByVal dNum As String, ByVal NCur As String, ByVal Ndec As String, ByVal co As Byte) As String Dim Td$, Td1$ On Error GoTo 1 If NCur = "" Then Ndec = "" Td = Format(Round(CCur(dNum - Int(dNum)), co), "0." & String(co, "0")) If Td = 0 Or Td = 1 Then Td1 = "": GoTo 1 If Len(Ndec) Then Ndec = " " & Ndec: Td1 = Td * CVar("1" & String(co, "0")) Else Ndec = " " & NCur: Td1 = Td Td1 = " و " & Chr(40) & Td1 & Chr(41) & Ndec 1: kh_dText = Td1 End Function دالة تحويل الرقم الى نص عربي.rar ================================================= الملف المعدل: هذا المرفق بامكانية تفقيط الكسر وامكانية ادخال كلمة نهاية النص دالة تحويل الرقم الى نص عربي.rar ================================================= رابط مباشر للملف

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

السلام عليكم ورحمة الله وبركاته أقدم لكم كيفية استخدام أداة التحكم RefEdit وكيفية استخدامها على الفورم ، وكيفية استغلالها للمعاينة أو الطباعة على سبيل المثال قم بإدراج فورم من قائمة Insert في محرر الأكواد ، ثم طبق الخطوات التالية كما في الصورة ، حيث يتم إدراج الأداة المسماة RefEdit1 ، وأيضاً إدراج زري أمر CommanButton1 و CommandButton2 أحدهما للمعاينة والآخر للطباعة وأخيراً ضع الكود التالي في حدث الفورم (كليك يمين على الفورم من نافذة المشروع ثم اختر View Code) لمزيد من المعلومات ولتحميل الملف المرفق انقر على الرابط التالي رابط الموضوع من هنا

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

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

و لإثراء الحلول هذه طريقة أخرى تؤدي نفس العمل Sub Test5() Application.ScreenUpdating = False For i = 2 To Cells(Rows.Count, 2).End(xlUp).Row If Not Cells(i, 1) = "" Then x = Range("A" & i).Row: GoTo 200: End If If Cells(i, 1) = "" Then xx = Range("A" & i).Row: GoTo 100: End If 100 With Range(Cells(x, 1), Cells(xx, 1)) .Merge: .HorizontalAlignment = xlCenter: .VerticalAlignment = xlCenter End With 200 Next Application.ScreenUpdating = True End Sub

اسمحلي بهذه الإجابة Dim i As Integer Dim j As Integer j = 0 Do j = j + 1 Loop Until Cells(j, 2).Value = "" For i = j - 2 To 1 Step -1 If Cells(i + 1, 1) = "" Then Range(Cells(i, 1), Cells(i + 1, 1)).Merge Next i طبعاً ينقصها التنسيق..

إنشاء جداول اكسس بالأكواد ♥ craet table with hard code ☺ craet table with hard code ☺.rar

الإجابة في هذا الكود: Cells.Find("name").Select ActiveCell.Offset(1, 0).Select Do Until ActiveCell.Value = "" If ActiveCell.Offset(0, 1).Value = "student" Then Range(ActiveCell, ActiveCell.End(xlToRight)).Interior.ColorIndex = 20 End If ActiveCell.Offset(1, 0).Select Loop لاحظ أننا استفدنا من عناوين الجدول للتعرف عليه أعتقد بأن الدالة find تبحث على الإسم بجميع صيغه. وتقبل تحياتي

For Each s In chose.ItemsSelected comment = comment & chose.ItemData(s) & vbCrLf Next

اخى الكريم جرب الملف المرفق نقل اسم المالك ورقم السيارة الجديد.rar

تم معالجة الامر تقسيم تلقائى لورقة العمل salim.rar

سأزيد المسألة تعقيداً.. انتظر السؤال التالي. لو كان للجدول عنوان ، ويوجد فراغ بينه وبين الجدول، فكيف سنطبق الكود؟ (شاهد الجدول التالي)

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

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

تفضل أخي الكريم Sample VL.rar

يظهر ان لديك جملة select او استعلام كمصدر للتقرير هناك حقلين بنفس الاسم ومن جدولين عليك التصريح باسم الجدول مع الحقل مثلا table1.fld1 بالتوفيق

في هذه الحالة علينا ان نحذف السطر : Range("a1").Select و نضع مكانه السطر : ActiveSheet.UsedRange.Select

الهدف الاول تحديد اول خلية في الجدول و ذلك يتم بواسطة هذا الكود Sub first_cell() For i = 1 To ActiveSheet.Columns.Count On Error Resume Next Set My_rg = Columns(i).SpecialCells(xlCellTypeConstants).Cells(1) If Not IsEmpty(My_rg) Then Err.Clear Exit For End If Next r = My_rg.Row: c = My_rg.Column '====================================== ' من هنا يمكن متابعة الكود 'بعد ان عرفنا اول خلية في الجدول '======================================= End Sub

حيث أن الكود السابق هو: وكل ما يمكنك التفكير به هو تغيير الكود بداخل المستطيل الأحمر

سؤالنا: ماذا لو غيرنا مكان الجدول، ولم نكن نعرف مكانه بالضبط ، كيف يمكننا تطبيق الكود السابق عليه، كالجدول التالي مثلاً: (زادت المسائل تعقيداً)

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

جميل و يمكن ان نستعمل كود آخر Sub Text3() i = 1 Do While i <= Cells(Rows.Count, "A").End(xlUp).Row If Trim(LCase(Cells(i, 2))) = Trim(LCase("student")) Then _ Range(Cells(i, 1), Cells(i, Cells(1, Columns.Count).End(xlToLeft).Column)).Interior.ColorIndex = 4 i = i + 1 Loop End Sub

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

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

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

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

عندها يلزم هذا الكود (مع الاخذ بعين الاعتبار مشاركتكم السابقة حول عدد الاعمدة) لم اذكرها هنا لضيق الوقت Sub salim1() lr = Cells(Rows.Count, 1).End(3).Row Range("a1:f" & Cells(Rows.Count, 1).End(3).Row).Interior.ColorIndex = xlNone Set my_rg = Range("a1:a" & lr).SpecialCells(xlCellTypeConstants) k = my_rg.Areas.Count For x = 1 To k For y = 1 To my_rg.Areas(x).Count If my_rg.Areas(x).Cells(y).Offset(0, 1) = "student" Then _ my_rg.Areas(x).Cells(y).Resize(1, 6).Interior.ColorIndex = 4 Next Next End Sub

الإجابة في هذا الكود: Range("a1").Select ActiveCell.Offset(1, 0).Select Do Until ActiveCell.Value = "" If ActiveCell.Offset(0, 1).Value = "student" Then Range(ActiveCell, ActiveCell.End(xlToRight)).Interior.ColorIndex = 20 End If ActiveCell.Offset(1, 0).Select Loop المرفق: loop_shaddow.rar

جزاك الله خيرا

بارك الله فيك وازادك الله جل وعلا علما شكرا جزيلا لك على هذا المجهود الاكثر من رائع

شكرا على هذا المجهود الرائع اخوكم شفان ريكاني

بسم الله ما شاء الله أخي العزيز الزباري بارك الله فيك وجزاك الله خيراً ..

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

اذا الاصل العيادة والطبيب طارىء ، لانه منطقيا احتمال تغير الاطباء

تم رفع هذا الكود فى مشاركة منفصله حتى لا ننسى هذه المشاركة كشف حساب جديد من اعمال عماد الحسامى تم ارفاق كود الحل من الفاضل ا / رحمه الله_ الحسامي و لا تنسونا من صالح الدعاء تحياتى كشف حساب (يومية عملاء و كشف بين تاريخين).rar ملخص شهري 555 (1).rar كشف حساب للفترة (1).rar

تحويل الارقام و العملات الى حروف دوال تفقيط جميع العملات والارقام على هذا الرابط http://www.officena.net/ib/index.php?showt...33&hl=تفقيط حبى وتقديرى مع وسام التميز الى كل الاساتذة اللذين ساعدو فى اثراء مكتبة الاكواد العربية بأعمال فريدة يعجز الاكسيل عن اداءها ولن نجد شبيه لها حتى الان فهى اكود يفخر بها منتدانا ويميزه دون المنتديات العربية قاطبة بصدور هذه الاكواد من منصة منتديات اوفيسنا . :: مع تحيات عاشق الاكواد المميزة ::