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

الحل هو هو جعل الاماكن المطلوب الكتابة فيها عبارة عن مربعات نص و بالتالي لا تخضع لحماية عند اختيار Tools Protect Documents Comments و لكن ليس مربعات النص العادية و لكن تلك التي توضع فى وضع تصميم الفيجوال بيزيك اختار اظهار مجموعة ايقونات الفيجوال من Toolbars Customize بالنقر علي شريط الأدوات ثم اختيار وضع التصميم بالضغط علي المربع الازرق ثم اختيار ال ToolBox و ووضع مربع نص و كل ذلك طبعا و الملف غير محمي ثم نختار Tools Protect Documents Comments فيتم حماية كل الملف ما عدا مربعات النص التي تم وضعها

تنسيق مفيد و خاصة للمحاسبين و التنسيق الذي وضعه الأخ شرف كالتالي : لمن لا يريد تنزيل الملف ### ### ### ##0.00;[Red](### ### ### ##0.00)

طريقتان الأولي : يتم ذلك بادراج section جديد و تكون له خصائص صفحة منفصلة و يتم ذلك من Insert Break Section Break Type Next Page مثلا الثانية من إعداد صفحة.. اختر السان حجم الورق ثم اختر اتجاه الصفحة كما تريد زمن ينطبق على اختر من هذه النقطة و الطريقة بالنسخة الانجليزية Page Setup Orientation : Landscape or Portrait Apply to : this Point Forward و هي طريقة أخري تؤدي أيضا لتكوين Section جديد

هذا الكود كتبته بناء علي طلب من أحد الأخوة ، كان يريد إستبدال المسافات فى ملف وورد بسطر جديد أي يريد توزيع الكلمات كل فى سطر جديد Sub replaceit() spacecount = 0 Selection.WholeStory scount = Selection.Characters.Count For i = 1 To scount If Selection.Characters(i).Text = " " Then spacecount = spacecount + 1 Next For i = 1 To spacecount Application.StatusBar = "Searching ...." & _ i & "/" & Mcount & " Please Wait......." With Selection.Find .Text = " " .Replacement.Text = "" End With 'If Selection.Find.Found = False Then Exit Sub Selection.Find.Execute Selection.TypeParagraph Next i End Sub replacespacewithenter.zip

أحيانا عند الاستيراد من خارج الاكسيل تجد تنسيق الخلايا لا يريد أن يتغير و عليك أن تمر علي خلية خلية لعمل double click ( نقر مذدوج ) أو تضغط F2 داخل كلية خلية قبل أن تتمكن من تغيير التنسيق و قد لا يكون ذلك مناسبا و هذا كود للقيام بتغيير تنسيق الخلايا المختارة الي "dd/mm/yyyy" علي سبيل المثال Sub Reenter_Format() Dim MyRow As Double, Z As String MyRow = Selection.Rows.Count For j = 1 To MyRow ActiveCell.Cells.NumberFormat = "dd/mm/yyyy" Z = ActiveCell.Value ActiveCell.Cells.FormulaR1C1 = Z ActiveCell.Offset(1, 0).Activate Next j End Sub Re_enterValues.zip

مع ملاحظة أن السطرين myrows = 20 mycols = 5 لتحديد مجال البحث ، و اذا اردت البحث بدءا من الخلية الفعالية الي آخر الشيت فأزل السطران Sub FindFirstEmpty() ' ' Application.ScreenUpdating = False Cells.Select myrows = Selection.Rows.Count mycols = Selection.Columns.Count myrows = 20 mycols = 5 origraw = myrows ActiveCell.Select For i = 0 To myrows - 1 For j = 0 To mycols - 1 If ActiveCell.Offset(i, j).FormulaR1C1 <> "" Then GoTo newrow End If Next MsgBox "Founf the Fist Empty Row " ActiveCell.Offset(i, j).Activate ActiveCell.EntireRow.Select Exit Sub ' ActiveCell.Offset(1, 0).Activate ' myrows = myrows - 1 newrow: Application.StatusBar = " checking ...." & _ Format(i / origraw, "0.0%") & " Please Wait......." Next i Application.ScreenUpdating = True Application.StatusBar = False End Sub FindFirstEmpty.zip

مثال 2 : استخدام AND , OR =+IF(AND(A1>10;A3>10);1000;2000) =+IF(OR(A1>10;A3>10);1000;2000) فى الاولي اذا كانت القيمة فى كل من الخليتين a1,a3 أكبر من 10 فالناتج 1000 و ان لم يكن فالناتج 2000 فى الثانية اذا كانت القيمة فى أي من الخليتين a1,a3 أكبر من 10 فالناتج 1000 و ان لم يكن فالناتج 2000 ExcelIF2.zip

مثال اذا كتبنا رقم فى الخلية a1 يظهر فى الخلية B1 جملة تبين اذا كان الرقم أكبر أو أصغرمن 10 و ذلك بوضع المعادلة التالية فى الخلية b1 =+IF(A1>10;"bigger than 10";" Less than 10") و المعادلة تنقسم الي 3 أقسام -الشرط -القيمة فى حالة تحقق الشرط - القيمة فى حالة عد تحققه و اذا أردنا الناتج رقم مكان جملة =+IF(A3>10;1000;2000) أي أن النتيجة 1000 اذا تحقق شرط كون القيمة فى a3 اكبر من 10 و 2000 اذا لم يتحقق ExcelIF.zip

للحصول علي كل من الرقم العشري و الرقم الصحيح فى خانة مستقلة يمكن عمل ذلك بخطوتين 1- الحصول علي الرقم الصحيح =+INT(C5) 2- الحصول علي ناتج القسمة عليه =+MOD(C5;C6) او علي خطوة واحدة بدمج المعادلتين =+MOD(C5;+INT(C5)) Mod.zip

لا أعلم طريقة لعمل معادلة بالمعني المفهوم ، أي تحدث مع تغير القيم و اتعامل معها من خلال ادراج ورقة اكسيل داخل الوورد و طريقة حساب المعادلات فى الوورد ، لابد من تكرارها مع التحديث ، و ما يشجعني علي تصور عدم وجود حل آخر هو هذه الجملة فى التعليمات Note Microsoft Word table calculations must be manually recalculated. Consider using Microsoft Excel to perform complex calculations. و الطريقة كما يلي نختار الخلية المطلوب حساب المعادلة فيها نختار formula فيظهر مربع الحوار التالي ثم نعدل المعادلة ان أردنا باستخدام نفس طريقة تسميات الخلايا فى الاكسل أو كلمة Above لكل ما هم أعلي أو Right لكل ما هو يمين الخلية و تكون النتيجة كالتالي و لكن لا تتحدث الا بتكرار ما سبق

و هذا المثال للعكس Vlookup2.zip

فى هذا المثال يتم استخدام الدالة vlookup للحصول علي اسم البلد بناء علي رقمها من قائمة vlookup.zip

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

مرفق مثال و هو يعتمد علي عمل اشارة مرجعية فى الخلية التي تسبق الرقم ثم التحرك منها الي الرقم و إضافة واحد عليه و لم يتم التحرك الي الرقم مباشرة لأن الاشارة المرجعية ستضيع فى هذه الحالة اذا تم تغيير القيمة Private Sub Document_Open() mm End Sub ----- Sub mm() Selection.GoTo What:=wdGoToBookmark, Name:="m1" Selection.MoveRight Unit:=wdCell Myval = Selection.Text Myval = CInt(Myval) + 1 Selection.TypeText Text:=Myval End Sub addoneOnOpen.rar

مثال به عدة طرق منها ما يعتمد علي دالة IF و ما يعتمد علي التنسيق الشرطي و منها الكود و هذا هو الجزء الخاص بالكود Private Sub Workbook_Open() If ActiveWorkbook.Worksheets(1).Range("d6").Value >= Now() Then MsgBox "the value in cell d6 is >= the current date !!" & Chr(13) & "BEST WISHES , FROM MOHAMED TAHER" End If End Sub و لرؤيته فى الملف اضغط ALT+F11 checkDate.zip

عندما نقوم بحماية ورقة العمل ، كيف يمكننا إستثناء بعض الخلايا من الحماية ؟؟ الإجابة : عن طريق استثناؤها من الحماية في الاكس بي Tools protection allow users to edit ranges ثم عرف المجال الذي تريد أو اختار الخلية و من القائمة المختصرة للماوس Format Cell و أزل خيار Locked ثم طبق الحماية علي ورقة العمل ستجد أن الخلية مستثناة من الحماية أي تقوم بعمل إستثناء للخلايا من الحماية عن طريق إختيارها ثم إختيار خصائص ، و حماية ، و الغاء تأمينها ثم عندما تطبق الحماية علي ورقة العمل ، تكون هذه الخلايا قد أستثنيت منها بالفعل

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

السؤال : كيف يمكن تثبيت خلايا معينة فى المعادلة عند عمل سحب أو Drag ؟ الاجابة : علم علي الجزء المراد تثبيته في المعادلة و هو هنا a1 ثم اضغط علي f4 ستظهر علامتين $ قبل رقم الصف و العمود و معني ذلك ان الصف و العمود ثابتين عند النسخ أو السحب و بضغطة أخري و ضغطة ثالثة يتم تثبيت الصف فقط أو العمود فقط و ما يناسب الحالة قد يكون هو اما تثبيت الصف و العمود $a$1 أو تثبيت الصف فقط a$1 أو تثبيت العمود فقط $a1

يمكن عمل ذلك باختيار الشيت ثم طباعته و يكون الاختيار باسم الشيت كما فى الكود الاول أو رقمه كما فى الكود الثاني و هما لطباعة الثلاث شيتات فى الملف أما الكود الاخير فهو لطباعة جميع أوراق العمل مع ملاحظة أن يكون فى الورقة أي بيان قابل للطباعة ( ليست خالية ) Sub Print3Sheets() ActiveWorkbook.Worksheets("sheet1").Select ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True ActiveWorkbook.Worksheets("sheet2").Select ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True ActiveWorkbook.Worksheets("sheet3").Select ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True End Sub Sub Print3Sheets2() ActiveWorkbook.Worksheets(1).Select ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True ActiveWorkbook.Worksheets(2).Select ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True ActiveWorkbook.Worksheets(3).Select ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True End Sub Sub PrintAllsheets() For i = 1 To ActiveWorkbook.Worksheets.Count ActiveWorkbook.Worksheets(i).Activate ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True Next End Sub PrintSheets2.rar

يمكن التغيير عند فتح الملف بالكود التالي Private Sub document_Open() SendKeys "{f10}" SendKeys "tms" SendKeys "{tab}" SendKeys "l" SendKeys "{ENTER}" End Sub و هو لتغيير الحماية الي المستوي المتوسط ثم التحكم فى الخيارات عند الاغلاق ، بالكود التالي Private Sub Document_Close() Dim z As String X = MsgBox("DO YOU WANT TO MODIFY SECURITY LEVEL ??", vbYesNo, "check for security level") If X = vbNo Then Exit Sub zz: z = UCase(InputBox("Press M for Medium adn H for High")) If z = "M" Then SendKeys "{f10}" SendKeys "tms" SendKeys "{tab}" SendKeys "m" SendKeys "{ENTER}" Exit Sub ElseIf z = "H" Then SendKeys "{f10}" SendKeys "tms" SendKeys "{tab}" SendKeys "h" SendKeys "{ENTER}" Exit Sub Else GoTo zz End If End Sub secrityLevel.rar

يمكن التغيير عند فتح الملف بالكود التالي Private Sub Workbook_Open() Application.SendKeys "{f10}" Application.SendKeys "tms" Application.SendKeys "{tab}" Application.SendKeys "l" Application.SendKeys "{ENTER}" End Sub و إضافة الي ذلك ، يمكن السؤال عند غلق الملف ، هل ترغب فى التغيير ام لا و من ثم تحديد هل تريد حماية متوسطة m أم قصوي H و من ثن تنفيذ التغيير قبل غلق الملف و ذلك بالكود التالي Private Sub Workbook_BeforeClose(Cancel As Boolean) Dim z As String X = MsgBox("DO YOU WANT TO MODIFY SECURITY LEVEL ??", vbYesNo, "check for security level") If X = vbNo Then Exit Sub zz: z = UCase(InputBox("Press M for Medium adn H for High")) If z = "M" Then Application.SendKeys "{f10}" Application.SendKeys "tms" Application.SendKeys "{tab}" Application.SendKeys "m" Application.SendKeys "{ENTER}" Exit Sub ElseIf z = "H" Then Application.SendKeys "{f10}" Application.SendKeys "tms" Application.SendKeys "{tab}" Application.SendKeys "h" Application.SendKeys "{ENTER}" Exit Sub Else GoTo zz End If End Sub security2.zip

مثال علي فصل ، و جمع القيم الموجبة و السالبة بطريقتين بالفصل فى عمودين ثم الجمع باستخدام IF او بالجمع مباشرة باستخدام SumIF positive_neg.zip

المثال الثاني مثل السابق مع الحماية باستخدام كلمة سر و هي 1234 لأن الحالة السابقة يمكن فك الحماية من القوائم مباشرة Sub Pr1() ActiveSheet.Protect Password:=1234, DrawingObjects:=True, Contents:=True, Scenarios:=True End Sub Sub Pr2() x = InputBox("please enter PAssword '1234'", "Password", 123) If x <> 1234 Then MsgBox "Sorry You are not Allowed !!! " Exit Sub End If ActiveSheet.Protect Password:=1234, DrawingObjects:=False, Contents:=False, Scenarios:=False End Sub UnprotectSheetPass.xls

المثال الأول يقوم بعمل الحماية Sub Pr1() ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True End Sub ثم فكها اذا كتبنا كلمة السر و هي 123 Sub Pr2() x = InputBox("please enter PAssword '123'", "Password", 123) If x <> 123 Then MsgBox "Sorry !!! " Exit Sub End If ActiveSheet.Protect DrawingObjects:=False, Contents:=False, Scenarios:=False End Sub UnprotectSheet.rar

مرفق ملف به عدد 2 ماكرو الاول يسألك عن رقم اللون ، ثم يختار الخلايا التي بها لون الخط المناظر و الثاني يعرض لك ألوان الخطوط و ارقامها بدءا من الخلية الفعالة Sub list_Cashes() Dim fs, S, A Set fs = CreateObject("Scripting.FileSystemObject") Set A = fs.CreateTextFile("c:\" & "temp.txt", True) A.writeline "Pivots in File named : " & ActiveWorkbook.FullName & " : " A.writeline A.writeline "*********** Prepared By Mohamed Taher *****************" A.writeline For i = 1 To ActiveWorkbook.PivotCaches.Count Dim tmpLine As String tmpLine = "Pivot Cash no. " & i & " : " & ActiveWorkbook.PivotCaches(i).SourceData A.writeline (tmpLine) Next i A.Close Dim x x = Shell("notepad.exe c:\temp.txt", 1) End Sub Sub list_RefreshonopenValue() 'Open "c:\temp.txt" For Output As #1 'Lineinput ,#1 "koko" ' Close #1 Dim fs, S, A Set fs = CreateObject("Scripting.FileSystemObject") Set A = fs.CreateTextFile("c:\" & "temp.txt", True) A.writeline "Pivots in File named : " & ActiveWorkbook.FullName & " : " A.writeline A.writeline "*********** Prepared By Mohamed Taher *****************" A.writeline For i = 1 To ActiveWorkbook.PivotCaches.Count Dim tmpLine As String tmpLine = "Pivot Cash no. " & i & " refresh on open status : " & ActiveWorkbook.PivotCaches(i).RefreshOnFileOpen A.writeline (tmpLine) Next i A.Close Dim x x = Shell("notepad.exe c:\temp.txt", 1) End Sub Sub refresh() For i = 1 To ActiveWorkbook.PivotCaches.Count ActiveWorkbook.PivotCaches(i).refresh Next i End Sub Sub List_PivSources_PerSheet() Dim fs, S, A Set fs = CreateObject("Scripting.FileSystemObject") Set A = fs.CreateTextFile("c:\" & "temp.txt", True) A.writeline "Pivots per Sheet - in File named : " & ActiveWorkbook.FullName & " : " A.writeline A.writeline "*********** Prepared By Mohamed Taher *****************" A.writeline For j = 1 To ActiveWorkbook.Worksheets.Count A.writeline A.writeline "Sheet named : " & ActiveWorkbook.Worksheets(j).Name A.writeline "----------" For k = 1 To ActiveWorkbook.Worksheets(j).PivotTables.Count Dim tmpLine As String tmpLine = "source of pivot no. " & j & " : " & ActiveWorkbook.Worksheets(j).PivotTables(k).SourceData A.writeline (tmpLine) Next k Next j A.Close Dim x x = Shell("notepad.exe c:\temp.txt", 1) 'ActiveWorkbook.Worksheets("Sheet3").PivotTables(1) _ .PivotFields("Year").Orientation = xlRowField End Sub Sub Do_RefreshonOpen() 'True if the PivotTable cache or query table is automatically updated each time the workbook is opened 'For Each pc In ActiveWorkbook.PivotCaches ' pc.RefreshOnFileOpen = True 'Next For i = 1 To ActiveWorkbook.PivotCaches.Count ActiveWorkbook.PivotCaches(i).RefreshOnFileOpen = True Next i End Sub Sub No_RefreshonOpen() 'True if the PivotTable cache or query table is automatically updated each time the workbook is opened 'For Each pc In ActiveWorkbook.PivotCaches ' pc.RefreshOnFileOpen = False 'Next For i = 1 To ActiveWorkbook.PivotCaches.Count ActiveWorkbook.PivotCaches(i).RefreshOnFileOpen = False Next i End Sub Sub Change_PivotCashes_RangeName() Dim fs, S, A Set fs = CreateObject("Scripting.FileSystemObject") Set A = fs.CreateTextFile("c:\" & "temp.txt", True) A.writeline "Change Pivot Sources per Sheet - in File named : " & ActiveWorkbook.FullName & " : " A.writeline A.writeline "*********** Prepared By Mohamed Taher *****************" A.writeline Dim x As String x = InputBox("PLease enter the Pivot Source Range Name", "Range name selection for Pivots", "SalesVillas") For j = 1 To ActiveWorkbook.Worksheets.Count A.writeline A.writeline "Sheet named : " & ActiveWorkbook.Worksheets(j).Name A.writeline "================" For k = 1 To ActiveWorkbook.Worksheets(j).PivotTables.Count On Error GoTo errsub Dim y As String y = ActiveWorkbook.Worksheets(j).PivotTables(k).SourceData A.writeline "Before : " & y ActiveWorkbook.Worksheets(j).PivotTables(k).SourceData = Trim(x) A.writeline "After : " & Trim(x) Next k Next j A.Close Dim z z = Shell("notepad.exe c:\temp.txt", 1) Exit Sub errsub: MsgBox Str(Err.Number) + Err.Description + "Action is cancelled" 'return original source ActiveWorkbook.Worksheets(j).PivotTables(k).SourceData = y Exit Sub End Sub SelectByFontColor.rar