محمد طاهر عرفه

تنسيق مختلف للخلايا التي بها كسور ، عن التي بها أرقام صحيحة =INT($G7)<>$G7 FractionConditionalFormat.rar

المثال المرفق يبين كيفية اختيار بيانات من مجال محدد عن طريق كومبو و اظهار النتيجة كصف فى مكان آخر و لأن هذه الطريقة تعيد القيمة فى خلية واحدة فقط فقد تم الاستعانة بالدالة vlookup لعرض باقي القيم أولا : من تخصيص اليقونات اضغط علي صندوق الادوات Toolbox و ختار القائمة المنسدلة combo box و ضعها فى ورقة العمل اختار القائمة المنسدلة بالزر الايمن ثم Format Control control وحدد مجال الادخال و النتيجة ( راجع المثال ) combo1.xlsx

احتجت لاعداد هذا الكود ، لانه فى بعض الاحيان تأتيني ملفات أجد حركتها بطيئة جدا بسبب تكرار لوجو لمرات كثيرة أو صورة ، نتيجة أن من أنشأ الملف ليس لديه خبرة كافية و هذا الكود يقوم بما يلي : عد الأشكال فى الملف اختيارها أو حذفها و كل منها فى ماكرو منفصل و أيضا به كودان جانبيان لادراج الوقت و التاريخ ( طبعا لاحاجة لهم لسهولة عمل ذلك بلوحة المفاتيح و لكن أتركهم فربما يحتاجهم أحد ) Sub SELECTallShapes() Application.SendKeys "{F5}{TAB}{TAB}{enter}B{enter}" End Sub Sub deleteallShapes() Application.SendKeys "{F5}{TAB}{TAB}{enter}b{enter}{del}" End Sub Sub inserttime() Application.SendKeys "^+;{ENTER}" End Sub Sub insertdate() Application.SendKeys "^;{ENTER}" End Sub Sub CountShapes() k = 0 With ActiveWorkbook.ActiveSheet.Shapes For i = 1 To .Count k = k + 1 Next Range("a1").Activate MsgBox k End With ' Set myDocument = Worksheets(1) 'myDocument.Shapes.Range(Array(1, 3)).Fill.Patterned _ msoPatternHorizontalBrick End Sub deleteshapes.zip

و هذا الكود المناظر لحذف الاسطر و هنا لم يتم اختيار مجال باسم محدد ، و لكن يتم التنفيذ بناء علي اختيار المستخدم للخلاية selection Sub deleteemptyRow() ' ' deleteemptyRow Macro ' Macro recorded 19/07/2000 by taher to delete empty rows in aselection Application.ScreenUpdating = False Dim MyRow As Long, origraw As Long ' Z As String MyRow = Selection.Rows.Count origraw = MyRow ActiveCell.Select 'MsgBox MyRow For i = 1 To MyRow If ActiveCell.Value <> "" Then ActiveCell.Offset(1, 0).Activate If ActiveCell.Value = "" Then ActiveCell.EntireRow.Delete MyRow = MyRow - 1 End If Application.StatusBar = "Parsing / deleting ...." & _ Format(i / origraw, "0.0%") & " Please Wait......." Next i Application.ScreenUpdating = True Application.StatusBar = False End Sub[/sql] DeleteemptyRows.zip

مثال لتحديد هل السجل متطابق مع غيره أم فريد ؟؟ و تحديد عدد مرات التكرار countif_if_condit.zip

من قائمة Format Sheet Backgroung و اختار الصورة ستجدها فى الخلفية background.rar

هذا المثال يقوم بنقل القيمة فى a1 الي b1 عند الفتح و مع تشغيل الماكرو المسمي ihaveseenit يتم تنفيذ نفس العملية و هو مثال علي تنفيذ عملية عند كل فتح للملف Private Sub Workbook_Open() x = ActiveWorkbook.Worksheets(1).Range("a1").Value 'MsgBox x ActiveWorkbook.Worksheets(1).Range("b1").Value = x End Sub Sub ihaveseenit() x = ActiveWorkbook.Worksheets(1).Range("a1").Value ActiveWorkbook.Worksheets(1).Range("b1").Value = x End Sub Autoupdatechange.zip

هذا المثال لاختبار التاريخ و تحديد هل يقع فى الاسبوع الحالي أم لا ؟ بطريقتين الاولي بالداوال علي أكثر من خطوة و الثانية بالكود Function THISWEEK(MYDATE) As Boolean If IsNull(MYDATE) Then THISWEEK = FLASE Exit Function End If Dim checkday As Byte, startdate As Date, enddate As Date checkday = Weekday(MYDATE, 1) If checkday = 7 Then checkday = 0 startdate = MYDATE - checkday enddate = startdate + 6 'MsgBox startdate 'MsgBox ENDDATE If ((startdate <= Now()) And (enddate >= Now())) Then THISWEEK = True Else THISWEEK = False End If End Function Function Myweekday(MYDATE As Date) Dim checkday As Byte checkday = Weekday(MYDATE, 1) If checkday = 7 Then checkday = 0 Myweekday = checkday End Function checkthisweek.zip

هذا الكود يقوم بملء الخلايا الخالية فى العمود المختار ، بنفس القيمة الموجودة فى اول خلية ، الي أن يصل الي خلية بها قيمة ، فيقوم باستخدام القيمة الجديدة وهو مفيد فى الحالة التالية مثلا ان العمود الاول مكتوب به البلد مرة واحدة ، و امامها عدة اسطر للموظفين ثم البلد التالية بعد عدة أسطر و هكذا و تريد فى قائمة طويلة مليء البلد امام كل موظف ، فما عليك الا التعليم علي اخلايا فى العمود المطلوب ملؤه ثم تشغل الماكرو التالي : ( راجع المثال لتكون الصورة أوضح ) :) Sub FillEmptyAsAbove() ' ' deleteemptyRow Macro ' Macro recorded 19/07/2000 by taher to delete empty rows in aselection Application.ScreenUpdating = False Dim MyRow As Long, origraw As Long ' Z As String MyRow = Selection.Rows.Count origraw = MyRow ActiveCell.Select 'MsgBox MyRow For i = 1 To MyRow - 1 'If ActiveCell.Value <> "" Then ActiveCell.Offset(1, 0).Activate If ActiveCell.Offset(i, 0).Value = "" Then 'ActiveCell.EntireRow.Delete 'MyRow = MyRow - 1 ActiveCell.Offset(i, 0).Value = ActiveCell.Offset(i - 1, 0).Value End If Application.StatusBar = "Parsing / deleting ...." & _ Format(i / origraw, "0.0%") & " Please Wait......." Next i Application.ScreenUpdating = True Application.StatusBar = False End Sub Fill_all_empty.zip

هذا الكود يقوم باخفاء الاسطر التي لا توجد بها أي قيم فى العمود B و يعتمد علي تسمية مجال محدد يسمي Myrange لتحديد عدد الصفوف المطلوب ادراء هذه العملية عليها Sub hidemptyRow_basedonthiscol() ' ' hideemptyRow Macro ' Macro recorded 25-12-02 by taher to hide empty rows in aselection Application.ScreenUpdating = False Application.Goto Reference:="myrange" Myrows = Selection.Rows.Count origraw = Myrows ActiveCell.Select For i = 1 To Myrows - 1 If ActiveCell.Value <> "" Then ActiveCell.Offset(1, 0).Activate If ActiveCell.Value = "" Then ActiveCell.EntireRow.Hidden = -1 ActiveCell.Offset(1, 0).Activate Myrows = Myrows - 1 End If Application.StatusBar = " checking ...." & _ Format(i / origraw, "0.0%") & " Please Wait......." Next i Application.ScreenUpdating = True Application.StatusBar = False End Sub[/sql] HideEmptyRows.zip

نفس المثال بالطريقة التقليدية لاضافة سنة =+DATE(YEAR(A1)+1;MONTH(A1);DAY(A1)) لاضافة 3 أشهر =+DATE(YEAR(A1);MONTH(A1)+3;DAY(A1)) لاضافة 5 أيام =+DATE(YEAR(A1);MONTH(A1);DAY(A1)+5) او =+A1+5 add_date2.zip

مثال آخر لحساب العمر بعدة طرق منها كود للأخ أبو هاجر agecalc.zip

مثال علي استخدام الدالة IF اذا كان التاريخ أكبر من قيمة محددة ، نحسب الغرامة بقيمة 50 جنيه ، و اذا لم يكن تكون 10% من المبلغ المستحق و طبيعة الدالة أنها تنقسم الي 3 أجزاء بينما فاصلو منقوطة ; الاول يعبر عن الشرط : اذا كان التاريخ أكبر من قيمة محددة الثاني القيمة الناتجة من الدالة فى حالة تحقق الشرط : 50 الثالث : القيمة الناتجة من الدالة فى حالة عدم تحقق الشرط : 10% من المبلغ =+IF(C4>=DATE(2003;1;1);50;A4*0.01) IFDATE2.zip

مثال آخر علي دالة لتحديد المجموعة بناء علي الرقم ثم تحليل النتائج باستخدام الجداول المحورية gradegroups.zip

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

دالة لاضافة شهور و سنين باستخدام DateAdd حيث لا يمكن استخدامها مباشرة فى ورقة العمل Function addmonth(mydate As Date, no As Integer) As Date addmonth = DateAdd("m", no, mydate) End Function Function addday(mydate As Date, no As Integer) As Date addday = DateAdd("d", no, mydate) End Function Function addyear(mydate As Date, no As Integer) As Date addyear = DateAdd("yyyy", no, mydate) End Function add_date.zip

Function refverseText(mycell) Dim mcount As Long, mtxt As String mcount = Len(mycell.Value) mtxt = mycell.Value Dim m As String For i = mcount To 1 Step -1 m = m & Mid(mtxt, i, 1) Next i refverseText = m End Function reversetext.zip

السناريو هو احد أدوات ال what-if analysis و هذه العبارة تعني باختصار تغيير بعض القيم لنري نتائجها علي المعادلات الموجودة فى ورقة العمل بمعني أنه لو هناك ثلاث سيناريوهات للبيع و الدخل مثلا كل منها له قيم مختلفة و بناء علي هذه القيم توجد معادلات أخري كثيرة و تود رؤية تأثير التغيير بين السيناريوهات الثلاثة علي النتيجة ، و بالطبع لا تريد أن تكتب القيم كلما أردت رؤية تأثيرها فاذهب الي قائمة tools scenarios add و حدد اسم السيناريو و حدد مجال ادخال القيم و ليكن E4:E5 كما فى المثال المرفق و هي الخلايا باللون الاصفر فى المثال و سيسألك عن القيم المراد تذكرها ، فاكتبها و أضف السيناريو الثاني و الثالث بنفس الأسلوب مع تغيير القيم والآن لتري تأثير السيناريوهات المختلفة علي النتائج Tools scenarios show و ستظهر قائمة السيناريوهات و كلما إخترت أحدها سيظهر تأثيره بالاضافة الي ذلك لتحصل علي مقارنة بين الثلاث سيناريوهات إختار زر summary و سيظهر لك خياران الاول يظهر مقارنة النتائج كما فى ورقة العمل المسماة Scenario Summary و هو سيستنتج خلية المنتيجة التي تريد مقارنتها ، و يمكنك تغييرها قبل التنفيذ و الثاني يظهر المقارنة فى جدول النتائج المحوري كما فى ورقة العمل المسماة Scenario PivotTable مع تحياتي scenarios.zip

هذا مثال لاستنتاج اسم الوردية بناء علي توقيت البدء باستخدام SELECT CASE Function getshift(mycell) Dim x As Double x = Round(mycell.Value, 1) Select Case x Case 7 To 15.5 getshift = "صباحية" Case 15.51 To 24 getshift = "وسطــي" Case 0 To 6.5 getshift = "مسائية" Case Is > 24 getshift = "توقيت خاطيء" End Select End Function shifts.zip

أحيانا تحتاج الي إظهار القيمة المناظرة لمعادلة مكتوبة بصورة نص لاستخدامها فى التوضيح ، مثلا (100-40)/2 و اذا أدرت إظهار المعادلات المكتوبة فهذا يظهر للشيت كله و ليس لبعض الخلايا فقط أما اذا أردت فقط اظهار بعض المعادلات علي هيئة نص مكتوب ، فلابد من أن تكون بتنسيق نص و لكن هذا لا يعني عدم استخدامها فى الحسابات :d المعادلة المكتوبة علي صورة نص فى الخلايا الصفراء مثل (100-40)/2 إختار الخلايا الخضراء ثم نفذ الماكرو ليسألك عن القيمة التي تود ضربها فيه او اضافتها اليها ا ثم يجري العملية و الكودان ، الاول للضرب و الثاني للجمع ( علي القيم المكتوبة كمعادلات نصية ) فاذا أردتها كما هي فاضرب فى 1 أو اجمع صفر ، و الخلية التي ستنتج يمكن استخدامها فى اي حسابات بعد ذلك Sub MakeValmultiply() Dim x As Double x = InputBox("select the Value to multiply", "Value to be multiplied to Text Formulas", 1) Dim myrow As Integer myrow = Selection.Rows.Count For i = 1 To myrow ActiveCell.Formula = "+" & ActiveCell.Offset(0, -1).Value & "*" & x ActiveCell.Offset(1, 0).Activate Next For i = 1 To myrow SendKeys "{f2}{Enter}" ActiveCell.Offset(-1, 0).Activate Next End Sub Sub MakeValadd() Dim x As Double x = InputBox("select the Value to add", "Value to be Added to Text Formulas", 1) Dim myrow As Integer myrow = Selection.Rows.Count For i = 1 To myrow ActiveCell.Formula = "+" & ActiveCell.Offset(0, -1).Value & "+" & x ActiveCell.Offset(1, 0).Activate Next For i = 1 To myrow SendKeys "{f2}{Enter}" ActiveCell.Offset(-1, 0).Activate Next End Sub ShowtxtFormulaValue.zip

مثال علي الجمع و الجمع الشرطي و جمع المضروب ٍsum sumif sumproduct sumIF.zip

فى المثال المرفق ثلاث طرق للتحكم فى البيانات المدخلة الأولي بالكود و هنا يتم التحقق من أن البيانات المدخلة فى الخلية d2 لابد أن تبدأ ب FGK Private Sub Worksheet_Change(ByVal Target As Range) If UCase(Left(Range("d2").Value, 3)) <> "FGK" Then MsgBox "Not Accepted Entry, should start with FGK" Range("d2").Value = "FGK" Exit Sub End If End Sub و الثانية عن طريق معادلة if الشرطية و اظهار النتيجة فى الخلية المجاورة و الثالثة عن طريق أمر Validation من قائمة data و عليه يوجد 3 امثلة الاول للتحكم بان الرقم بين 10 و 100 و الثاني لأن النص لا يزيد عن 5 حروف و الاخير لان الرقم أقل من 1000 و فى الاخير تم استخدام خاصية الرسالة التي تظهر عند الوقوف فى الخلية و تغيير رسالة الخطأ و ذلك ايضا من امر validation من قائمة data Validation.zip

إختلاف التنسيق لأحد أيام الاسبوع و ليكن الجمعة مثلا ( بناء علي التاريخ ) و ذلك بوضع شرط التنسيق Formula is : =WEEKDAY(D5;1)=6 weekdayconditional.zip

Format Borders and Shading Page Border Option Measure from Text أو حل آخر بقم يتصغير مقاس الورقة من اعدادات الصفحة

هذا كود لعمل احصائية لانواع الحروف المختلفة Dim LetterMat(2, 256) As Variant Sub Countaletter() For i = 32 To 255 LetterMat(2, i) = 0 Next For i = 32 To 255 LetterMat(1, i) = Chr(i) Next Application.ScreenUpdating = True Mycounter = 0 Selection.WholeStory Mcount = Selection.Characters.Count ' MsgBox mcount For i = 1 To Mcount With Selection.Characters(i) Application.StatusBar = "Searching ...." & _ i & "/" & Mcount & " Please Wait......." For j = 32 To 255 If .Text = LetterMat(1, j) Then LetterMat(2, j) = _ LetterMat(2, j) + 1 Next End With Next i Dim m As String For j = 32 To 64 m = m + (LetterMat(1, j)) + ":" + _ Str(LetterMat(2, j)) + " " ' + Chr(13) If j Mod 3 = 0 Then m = m + Chr(13) Next MsgBox m m = "" For j = 65 To 90 m = m + (LetterMat(1, j)) + ":" + _ Str(LetterMat(2, j)) + " " ' + Chr(13) If j Mod 3 = 0 Then m = m + Chr(13) Next MsgBox m m = "" For j = 91 To 122 m = m + (LetterMat(1, j)) + ":" + _ Str(LetterMat(2, j)) + " " ' + Chr(13) If j Mod 3 = 0 Then m = m + Chr(13) Next MsgBox m m = "" For j = 123 To 192 m = m + (LetterMat(1, j)) + ":" + _ Str(LetterMat(2, j)) + " " ' + Chr(13) If j Mod 3 = 0 Then m = m + Chr(13) Next MsgBox m m = "" For j = 192 To 255 m = m + (LetterMat(1, j)) + ":" + _ Str(LetterMat(2, j)) + " " ' + Chr(13) If j Mod 3 = 0 Then m = m + Chr(13) Next MsgBox m End Sub CountallLetternew.zip