علي السحيب

تم عمل جميع التعديلات المطلوبة على الملف المرفق، فأصبح الكود الخاص بالصفحة هو: Private Sub Worksheet_Change(ByVal Target As Range) TC = Target.Column TR = Target.Row If TR = 4 Or TR = 10 Then Exit Sub If TC = 1 And TR > 1 And TR <= 10 Then Cells(TR, 2) = Cells(TR, 2) + 1 If TC = 10 And TR > 1 And TR < 30 Then [B10] = [B10] + 1 End Sub وتم إضافة كود آخر يعمل عند فتح الملف .. وهو يعمل على إدخال التاريخ في الخية A4 .. وزيادة العدد في الخلية B4 إذا كان التاريخ المُدخل يختلف عن الموجود مسبقاً. Private Sub Workbook_Open() Dim DiffDays As Long OldDate = [A4] [A4] = Date DiffDays = DateDiff("d", OldDate, [A4]) [B4] = [B4] + DiffDays End Sub _______________________.rar

المرفق يحتوي على طريقة جديدة لترحيل البيانات .. وهي ترحيل بيانات الصف الذي تقف عليه .. أي أنه لا ينبغي عليك أن تحدد داخل الكود الصف الذي تريد ترحيل بياناته .. فقط قف على أي صف تريد وأضغط زر الترحيل وسوف يتم ترحيل البيانات إلى أي مكان تريد .. سواء إلى قاعدة بيانات .. أو لتعبئة نموذج ما بعض ما يحتوي عليه المرفق، 1. تلوين جميع بيانات الصف الذي تقف عليه. 2. تعبئة نموذج موجود في نفس ورقة العمل بمجرد الوقوف على أي صف يحتوي على بيانات. 3. ترحيل بيانات الصف الذي تقف عليه بمجرد الضغط المزدوج بزر الفأرة على أي خلية من ذلك الصف. 4. خروج رسالة لتأكيد ترحيل البيانات. 5. بعد الترحيل يتم تحديث الترقيم التسلسلي لكل من البيانات في الصفحة الرئيسية والبيانات في الصفحة الفرعية. 6. وجود زر في كل من الصفحة الرئيسة والفرعية لتحديث الترقيم التسلسلي متى شئت. 7. تعبئة نموذج آخر موجود في ورقة عمل أخرى ببيانات الصف الذي تقف عليه حالياً. 8. التنبيه في حالة كون الصف الذي تقف عليه غير داخل ضمن نطاق البيانات المُعدة للترحيل. 9. التنبيه في حالة كون الصف الذي تقف عليه خالياً من البيانات. أتمنى أن يستفيد الجميع من هذه الإضافة، __________________________________________________.rar

الكود الذي طرحته في مشاركتي السابقة يعمل على خلية واحدة فقط .. أما إذا أردناه أن يعمل على مجموعة من الخلايا .. يتم التعديل عليه ليصبح كالتالي: وهو يعمل عند تحرير أي من الخلايا الواقعة في النطاق (BV60:BV119) Private Sub Worksheet_Change(ByVal Target As Range) R = Target.Row C = Target.Column If C = 74 And R >= 60 And R <= 119 Then If Range("BV" & R) = 3 Then Range("BT" & R) = 1 If Range("BV" & R) = 5 Then Range("BU" & R) = 1 End If End Sub أما إذا أردناه أن يعمل من خلال زر ماكرو فيكون الكود بهذه الصورة: Sub ForAll() Application.ScreenUpdating = False [BT60:BU119].ClearContents For A = 60 To 199 If Range("BV" & A) = 3 Then Range("BT" & A) = 1 If Range("BV" & A) = 5 Then Range("BU" & A) = 1 Next Application.ScreenUpdating = True End Sub ______________.rar

راجع الرابط التالي: http://www.officena.net/ib/index.php?showtopic=11477&hl=

في هذه الحالة ينبغي إستخدام الدالة COUNTIF: =COUNTIF(A1:A100,"ممتاز")

الأخوان halwim و Nse و Salman a .. إذا سمحتوا لي: الكود الذي أرفقه الأخ Nse .. يعمل بشكل ممتاز .. ولكنه طويل بعض الشيء وبإمكاننا إختصاره ليصبح بالشكل التالي: Private Sub Worksheet_Change(ByVal Target As Range) TA = Target.Address If TA = "$E$2" Then [C2] = [C2] + [A2] If TA = "$E$3" Then [C3] = [C3] + [A3] If TA = "$E$4" Then [C4] = [C4] + [A4] If TA = "$E$5" Then [C5] = [C5] + [A5] If TA = "$E$6" Then [C6] = [C6] + [A6] If TA = "$E$7" Then [C7] = [C7] + [A7] If TA = "$E$8" Then [C8] = [C8] + [A8] If TA = "$E$9" Then [C9] = [C9] + [A9] If TA = "$E$10" Then [C10] = [C10] + [A10] If TA = "$E$11" Then [C11] = [C11] + [A11] If TA = "$E$12" Then [C12] = [C12] + [A12] If TA = "$E$13" Then [C13] = [C13] + [A13] If TA = "$E$14" Then [C14] = [C14] + [A14] If TA = "$E$15" Then [C15] = [C15] + [A15] End Sub وبإمكاننا أيضاً إختصار الكود السابق بشكل أكبر ليصبح هكذا: Private Sub Worksheet_Change(ByVal Target As Range) TR = Target.Row TC = Target.Column If TC = 5 And TR > 1 And TR <= 15 Then _ Range("C" & TR) = Range("C" & TR) + Range("A" & TR) End Sub أتمنى أن يستفيد الجميع من هذه التعديل، LOOP.rar

تم التعديل على الملف حسب المطلوب، ولمعلومات أكثر حول هذا النوع من التحويل راجع الرابط التالي: http://www.officena.net/ib/index.php?showtopic=9365&hl= ________________________________.rar

يكون الكود كالتالي: Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = "$B$1" Then [A1:A2].ClearContents If [B1] = 3 Then [A1] = 1 If [B1] = 5 Then [A2] = 1 End If End Sub If_In_VBA.rar

المرفق التالي يحتوي على أربع طرق لعمل ترقيم تلقائي .. أختر منها ما شئت .. وإن لم تستطع التعامل مع الصيغ .. أرسل الملف الذي تعمل عليه أو ملف آخر مشابه له ليجري التعديل عليه، _________________________.rar

في هذه الحالة يكون الكود هكذا: Sub Alert() MsgBox "الخلية تحتوي على كلمة " & Sheets("BB").[A1] End Sub

جرب عمل التصفية عن طريق الدوال .. كما في الرابط التالي: http://www.officena.net/ib/index.php?showtopic=13808

استخدم الصيغة التالية لحصر الأرقام العشوائية بين 1 - 200. =RAND()*(1-200)+200

لا أدري مالحاجة إلى إستخدام الكود .. وإمكانيات الإكسل المتاحة تفي بالغرض!!! =IF(B1="","",NOW())

الكود التالي يعطيك محتويات الخلية A1 : Sub Alert() MsgBox "الخلية تحتوي على كلمة " & [A1] End Sub

راجع الرابط التالي: http://www.officena.net/ib/index.php?showtopic=13135

أشكرك أخي عمر على مساهمتك في هذا الموضوع، وأنا أيضاً قمت بإعداد كود أخر يقوم بنفس الغرض .. وعلى رأي المثل (زيادة الخير .. خيرين) وهذا هو الكود: Private Sub Worksheet_Activate() On Error Resume Next Application.ScreenUpdating = False For C = 2 To 20 If Cells(C, 1) <> "" Then Cells(C, 2) = "=VLOOKUP(INDIRECT(ADDRESS(ROW(),COLUMN()-1)),[Test.xls]Sheet1!$A$2:$B$20,2,0)" End If Next [B2:B20].Copy [B2].PasteSpecial Paste:=xlPasteValues Application.CutCopyMode = False [B2].Select Application.ScreenUpdating = True End Sub Vlookup__Activate_.rar

تم التعديل على المرفق لعدم تكرار البيانات، ______________________.rar

راجع الرابط التالي: http://www.officena.net/ib/index.php?showtopic=7486 شاهد المرفق من عمل الأستاذ محمد حجازي، ____________________________.rar

بالنسبة لإظهار الآلة الحاسبة في الإكسل .. راجع الرابط التالي: http://www.officena.net/ib/index.php?showtopic=5971

بالنسبة للبحث في ملف آخر .. فإلى الأن لم أتوصل إلى الحل المناسب. أما بالنسبة لتجاهل الخطأ وإلغاء خروج الرسالة التنبيهية .. فقم بإستبدال السطر التالي في الكود .. MsgBox "هناك رقم أو أكثر غير موجودة في البيانات الأساسية", vbExclamation, "أرقام غير موجودة" إلى هذا السطر: Me.Activate

شاهد المرفق، __________________________________.rar

تم التعديل، 111.rar

شاهد المرفق .. من عمل الأستاذ الكبير أبو هادي، UmAlQura.rar

يتم تنفيذ ذلك عن طريق الكود .. كما هو وارد في الرابط الموجود في مشاركتي السابقة. نعم يمكن عمل ذلك .. راجع الرابط التالي: http://www.officena.net/ib/index.php?showtopic=7486

If Sheet1.ComboBox1 = Sheet1.[I15] Then ActiveSheet.Rows.Hidden = False هذا الجزء يقوم بفحص محتوى الخلية I15 في الصفحة الأولى والتي تحتوي على الكلمة (الجميع)، فإذا كانت هي نفسها الكلمة الموجودة في القائمة المنسدلة .. فإنه يتم إظهار جميع الصوف المخفية .. وبذلك يتم عرض جميع النتائج. If Sheet1.ComboBox1 <> Sheet1.[I15] Then إذا كان محتوى الخلية I15 غير مساوي للكلمة الموجودة في القائمة المنسدلة فإنه يبدأ عمل الكود بإخفاء جميع الصفوف التي لا تساوي الكلمة الموجودة في القائمة المنسدلة في عمودها السادس. For A = 6 To 1000 هذا السطر لتحديد أول صوف وآخر صف من الصفوف التي سيعمل عليها الكود. BR = ActiveSheet.Cells(A, 6) هنا لفحص محتوى كل خلية في العمود السادس في نطاق الصفوف المشار إليه. ActiveWindow.SmallScroll Down:=-100 هذا السطر يعمل على الوقوف على بداية الصفحة بعد إخفاء الصفوف الغير مرغوب فيها. وبالنسبة لنقل القائمة المنسدلة أو إنشاء قائمة جديدة .. راجع الرابط التالي: http://www.officena.net/ib/index.php?showtopic=13038