السيد عبد العال

السلام عليكم ورحمة الله وبركاته أرجو أت يكون هذا هو الماكرو المطلوب Sub FindAndSet() Dim strFind As String, strSet As String Dim shSheet As Worksheet strFind = "Carried" strSet = "L.E" For Each shSheet In ThisWorkbook.Worksheets For Each cCell In shSheet.Range("A:A") If cCell.Value = strFind Then cCell.Offset(0, 3).Value = strSet End If Next cCell Next shSheet End Sub

أخى الكريم على ما فى هذه العملية من ضعف شديد ومشاكل عديدة إليك هذه الخطوات:- 1 - يتم إعداد البيانات فى الإكسل وطبعا لكى يتم التعامل مع هذه البيانات بصورة جيدة يراعى ان تخضع لخصائص حقول قواعد البيانات بحيث تكون الأعمدة مشابهة للحقول يحتوى كل عمود على نوع واحد من البيانت كان تكون رقمية أو نصية وهكذا. ويراعى أن يكون الصف الأول محتويا على اسماء الحقول ويمكن التعامل على أن الشيت الواحدة مكافئة لجدول قاعدة بيانات أو عمل ذلك فى جزء من الشيت ثم أعطاءه من Insert -> Name -> Define 2-يتم فتح قاعدة بيانات فارغة فى الأكسس -لا يشترط أن تكون فارغة_ 3 -يتم الوقوف على الجداول ثم من قائمة File ->Get External Data-> Linked Tables يؤدى ذلك إلى صندوق حوارى بعنوان Link فى أسفل الصندوق الحوارى خانةFile of Type يعرض انواع الملفات التى يمكن الربط عليها مبدئا بال Access يتم اختيار MicroSoft Excell ثم تحديد مكان واسم الملف المراد الربط عليه 4-يخرج صندوق حوارى بعنوان Link Spreadsheet Wizerd يتم تحديد وضع البيانات هل هى على مستوى الشيت أم Named Rage ثم Next 5-فى الشاشة التالية يتم تنشيط الأختيار الدال على أن اول صف يحتوى على أسماء الحقول ثم Next 6- يتم إعطاء اسم للجدول ثم finish 7- يظهر الجدول وبجواره سهم ليخبرنا انه مرتبط وتظهر ايقونة الجدول بشكل ايقونة الأكسل ليشر ان الربط مع جدول اكسل 8- يتم التعامل معه كاى جدول فى الاكسس يلاحظ أن الخلية التى تحتوى على معادلات لا يمكن تعديل قيمتها من اكسس مرفق ملف به تطبيق كالسابق - لسهولة الستخدام يرجى وضعى الملفيين على فولدر باسم C:\Sayed\s\ExcelLink Xls_Access.zip

بالنسبة للموضوع الاساسى لهذه المشاركة وإضافة للدرس الجميل للاخ المهندس / محمد طاهر فى التعريف على VBA: فقد فهمت من سؤالك أنك تريد استخدام الدوال الاساسية للأكسل (مثل Sum ,min)- والتى قد لا يوجد مثيل أومكافئ لها فى الدوال الأساساية للبيزيك - تريد استخدامها داخل محرر VBA: ولهذا الغرض قامت مايكروسوف بعمل WorksheetFunction Object ضمن كاتنات Microsoft Excel Visual Basic يوجد مثال فى صفحة المساعدة الخاصة بهذا الكائن فى الاكسل يراعى ان متغيرات الدوال لا يشار إليها كما يتم داخل الشيت بمعنى أنك اذا أردت أن تقول A1 فلا تكتبها هكذا مباشرة ولكن تستخدم مثل هذه الطريقة Range("A1") وإليك ملخص المساعدة والمثال: WorksheetFunction ObjectUsed as a container for Microsoft Excel worksheet functions that can be called from Visual Basic. Using the WorksheetFunction Object Use the WorksheetFunction property to return the WorksheetFunction object. The following example displays the result of applying the Min worksheet function to the range A1:A10 . Set myRange = Worksheets("Sheet1").Range("A1:A10") answer = Application.WorksheetFunction.Min(myRange) MsgBox answer

ActiveCell.Offset(0, -1).Select

شكرا أخى أبو مؤنس على المعلومة وإن كنت أظن أن أن العمل فى ملف واحد . وعموما أرجو ان لا يسبب الكود الآتى مشاكل: Sub sDrawOval() If TypeName(Selection) <> "Range" Then Exit Sub Dim ssRange As Range Set ssRange = Selection DrawOvals ssRange, 48, 0.2 End Sub Function fDrawOval(ByVal fRange As Range, Optional ByVal MinDegree As Single = 0, Optional ByVal MarginRatio As Single = 0) As String If IsEmpty(fRange) Then Exit Function DrawOvals fRange, MinDegree, MarginRatio End Function Function DrawOvals(sRange As Range, MinDegree As Single, OvMargRatio As Single) Dim cCell As Range Dim shShape As Shape Dim OvName As String Dim MrH As Single, MrW As Single, OvalW As Single, OvalH As Single On Error GoTo DR_OVAL_Err For Each cCell In sRange OvName = "oval" + cCell.AddressLocal If IsExistShape(OvName, cCell) Then If cCell.Value >= MinDegree Or cCell.Formula = "" Then cCell.Worksheet.Shapes(OvName).Delete End If Else If cCell.Value < MinDegree And cCell.Formula <> "" Then MrH = OvMargRatio * cCell.Height MrW = OvMargRatio * cCell.Width OvalW = cCell.Width - MrW OvalH = cCell.Height - MrH Set shShape = cCell.Worksheet.Shapes.AddShape(msoShapeOval, cCell.Left + MrW / 2, cCell.Top + MrH / 2, OvalW, OvalH) With shShape .Name = OvName .Fill.Transparency = 1# .Fill.Visible = msoFalse .Line.ForeColor.RGB = RGB(255, 0, 0) .Line.Weight = 1.25 End With End If End If Next Set cCell = Nothing Exit Function DR_OVAL_Err: MsgBox Err & " : " & Error Err.Clear Resume Next End Function Function IsExistShape(ShapeName As String, cCell As Range) As Boolean Dim shShape As Shape IsExistShape = False For Each shShape In cCell.Worksheet.Shapes If shShape.Name = ShapeName Then IsExistShape = True Exit Function End If Next shShape End Function Sub sClearAllOvals() Dim shShape As Shape For Each shShape In ActiveSheet.Shapes If Mid(shShape.Name, 1, 4) = "oval" Then shShape.Delete Next End Sub ومعلوم ان بهذا الكود مشكلتان: 1- خطأ فى حساب الإحداثى السينى للأشكال (الدوائر ) عندما يتم توليدها فى شيت ذات اتجاه من اليمين إلى اليسار عندما تكون نسبة zoom مختلفة عن 100% - لا تحدث هذه المشكلة عندما يكون اتجاه الشيت من اليسار لليمين. 2- لا يعمل بصورة جيدة فى حالة حذف أو إدراج صف أو عمود - برجاء تجربة الحالات المختلفة .

الأخ الاستاذ حسام نور الأخ الاستاذ عادل حسين الأخ المهندس / محمد طاهر جزاكم الله خيرا على هذا التشجيع لازلت هناك مشكلة لم أطرحها بعد لانشغالنا بالمشكلة السابقة: Bug: ماذا يحدث للدالة fDrawOval() عند حذف أوإضافة خلايا اوصفوف أو أعمدة من ال Range المحدد فى متغيراتها؟

ليس ضروريا يا أخى ولكن يفضل كتاباتها لسهولة المراجعة والتعديل خاصة حينما تكثر هذه ال Loops ويقوم البرنامج بالبحث عن كل كلمة next المقابلة لكل كلمة for تم استخدامها ويرسل رسالة خطأ عند وجود عدم تطابق الجدير بالذكر هنا أنه عند فتح for ثم فتح For أخرى داخلها فيجب أغلا ق الثانية ثم الاولى

أخى الفضل قبل كل شئ أحب أن أحيك على مستوى العمل الذى قمتم به فإخراجه جميل ثانيا: إليكم ماكرو أخرى أضافة إلى الماكروهات السابقة وهى تقوم بمسح جميع الدوائر فى الشيت النشطة عند استدعائها Sub sClearAllOvals() Dim shShape As Shape For Each shShape In ActiveSheet.Shapes If Mid(shShape.Name, 1, 4) = "oval" Then shShape.Delete Next End Sub أما المشكلة فى الكود السابق هى ان الأكسل يحدث منه خطأ فى حساب الإحداثيات الخاصة بالدوائر والخلايا عندما تكون نسبة ال Zoom مختلفة عن 100% لهذا السبب كانت الدوائر ترسم فى أماكن مختلفة عنالماكن المتوقع لها كأن ترسم فى أقصى يسار الشييت وعموما سأحاول معرفة كيفية تأثير هذه العلاقات وكحل مبدئى يمكن لسيادتكم ضبط نسبة View -> Zoom إلى 100% عند العمل وتصورى للخطوات هو كالتالى: - يتم نقل الماكرو السلبق إلى الModule - يتم ضبط Zoom 100% يتم استدعاء الماكرو sClearAllOvals يتم عمل Copy ثم Paste فى نفس مكانه من الصف ذو الخلايا الصفراء وبالتالى تقوم الدوال بالرسم مرة أخرى يكرر العمل السابق لكل الشيتات ولكم تحياتى والسلام عليكم ورحمة الله

معذرة يا أخى إليك الملف الصحيح ovs4xp.zip

أخى الفاضل رغم اقتناعى بعدم وجود ضرورة لهذه الماكرو والأفضل هو استخدام المعادلات العادية والطرق الموجودة فى الاسك كما \اشار الأخوة سابقا إليك الماكرو المطلوبة يتم اختيار الخلايا كلها ثم تشغيل الماكرو Sub MarkBside() Dim cCell As Range For Each cCell In Selection If cCell.Formula <> "" Then cCell.Offset(0, 1).Value = 1 Next End Sub

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

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

السلام عليكم وهل تظهر الماكرو المسماة sDrawOval فى قائمة الماكرو؟ وهل تظهر الدالة fDrawOval فى معالج الدوال تحت التصنيف المسمى User Defined?

السلام عليكم المعادلة الثانية تعتمد على وجود الكود أى بعد نسخ الكود فى module يتم كتابة المعادلة ويتم التعامل معها مثل اى معادلة فى الأكسل ويمكن كتاباتها باحد طريقتين يتم اختيار خانة بعيد ا عن المنطقة التى بها الدرجات و يكتب فيها معادلة شبيهة بهذه: =fDrawOval(B2:J20;60;0.2) مع مراعة تغيير B2:j20 ليصبح هو اسم المنطقة التى بها الدرجاتوكذللك استخدم الفاصلة بدلا من الفاصلة المنقوطة إذا كان نظامك يستلزم ذلك الطريقة الثانية لكتابة الالة هى معالج الدوال من القائمة: Insert -> Function تؤدى الى الى ظهور مربع حوارى نحتار من الصندوق بجوار cateegry User Defined فتظهر الدوال ومنها fDrawOval فيتم إختيارها واسكمال الصندوق الحوارى الخاص بها والذى يظهر فيه مكان لثلاث متغيرات ٍsRange MinDegree OvMargRatio

أخى عادل حسين حياكم الله إليكم التعديلات المطلوبة Sub sDrawOval() If TypeName(Selection) <> "Range" Then Exit Sub Dim ssRange As Range Set ssRange = Selection DrawOvals ssRange, 60, 0.2 End Sub Function fDrawOval(ByVal fRange As Range, MinDegree As Single, MarginRatio As Single) As String Application.Volatile DrawOvals fRange, MinDegree, MarginRatio fDrawOval = "" End Function Function DrawOvals(sRange As Range, MinDegree As Single, OvMargRatio As Single) Dim cCell As Range Dim shShape As Shape Dim OvName As String, OvSheet As String On Error GoTo DR_OVAL_Err For Each cCell In sRange OvName = "oval" + cCell.AddressLocal OvSheet = cCell.Worksheet.Name If IsExistShape(OvName, OvSheet) Then If cCell.Value >= MinDegree Or cCell.Formula = "" Then cCell.Worksheet.Shapes(OvName).Delete End If Else If cCell.Value < MinDegree And cCell.Formula <> "" Then MrH = OvMargRatio * cCell.Height MrW = OvMargRatio * cCell.Width OvalW = cCell.Width - MrW OvalH = cCell.Height - MrH Set shShape = cCell.Worksheet.Shapes.AddShape(msoShapeOval, cCell.Left + MrW / 2, cCell.Top + MrH / 2, OvalW, OvalH) With shShape .Name = OvName .Fill.Transparency = 1# .Fill.Visible = msoFalse .Line.ForeColor.RGB = RGB(255, 0, 0) .Line.Weight = 1.25 End With End If End If Next Set cCell = Nothing Exit Function DR_OVAL_Err: MsgBox Err & " : " & Error Err.Clear Resume Next End Function Function IsExistShape(ShapeName As String, SheetName As String) As Boolean Dim shShape As Shape IsExistShape = False For Each shShape In ThisWorkbook.Worksheets(SheetName).Shapes If shShape.Name = ShapeName Then IsExistShape = True Exit Function End If Next shShape End Function وهو يستخدم بإحدى طريقتين الاولى ماكرو باسم sDrawOval ييم تشغيله بعد اختيار المنطقة المرادة والثانية عبارة عن دالة -ففى أى خلية بعيدة عن المنطقة الملوب رسم الدوائر لها يتم كتابة مثل هذه المعادلة: =fDrawOval(c3:M24;60;.2( حيث c3:m234 هى الخلايا المطلوب رسم دائرة لها 60 الحد الأدنى 0.2 هى نسبة الهامش المتروك بين القطع وحدود الخلية مع تحياتى

أخى الفاضل الكود المرفق يقوم برسم قطع ناقص (Oval) حول الخلية التى بها رقم أقل من60 حيث يتم اختيار الخلاايا المطلوبة وتشغيل الماكرو. يقوم البرنامج بالرمور على كل خليةفى الخلاياالمختارة ومقارنة قيمتها ب الحد الأدنى فى حالة أن القيمة أقل يقوم البرنامج بإضافة القطع بطول وعرض الخلية وتغيير لون أطاره إلى الأحمر وجعله شفاف واعطاءه اسم (عبارة عن عنوان الخلية مضاف إلى كلمة oval). أذا كانت أكبر من الحدالأدنى يتأكد البرنامج من عدم وجود القطع وإذا كان موجودا يقوم بحذفه. - يتجاهل البرنامج الخلايا الفارغة وكذلك التى ليس بها قيمة عددية وإذا كان بها دائرة (قطع) يقوم بمسحها. - البرنامج زود بخاصية _ يمكن تفعيلها لجعل القطع أقل من عرض وارتفاع الخلية. -يحتوى على function للتاكد من وجود القطع . اتمنى ان يكون مناسبا والسلام عليكم ورحمة الله. Sub DrawOval() Dim fCompDegree As Single, OvMargRatio As Single fCompDegree = 60 OvMargRatio = 0 ' Margin Ratio Dim cCell As Range Dim sRange As Range Dim shShape As Shape Dim OvName As String On Error GoTo DR_OVAL_Err If TypeName(Selection) <> "Range" Then MsgBox "SElEct Range to Ckeck" Exit Sub End If Set sRange = Selection For Each cCell In Selection OvName = "oval" + cCell.AddressLocal If IsExistShape(OvName) Then If cCell.Value >= 60 Or cCell.Formula = "" Then ActiveSheet.Shapes(OvName).Delete End If Else If cCell.Value < 60 And cCell.Formula <> "" Then MrH = OvMargRatio * cCell.Height / 2 MrW = OvMargRatio * cCell.Width Set shShape = ActiveSheet.Shapes.AddShape(msoShapeOval, cCell.Left + MrW / 2, cCell.Top + MrH / 2, cCell.Width - MrW, cCell.Height - MrH) With shShape .Name = OvName .Fill.Transparency = 1# .Line.ForeColor.SchemeColor = 10 End With End If End If Next Set cCell = Nothing Set sRange = Nothing Exit Sub DR_OVAL_Err: MsgBox Err & " : " & Error Err.Clear Resume Next End Sub Function IsExistShape(ShapeName As String) As Boolean Dim shShape As Shape IsExistShape = False For Each shShape In ActiveSheet.Shapes If shShape.Name = ShapeName Then IsExistShape = True Exit Function End If Next shShape End Function

Sub DrawOval() Dim cCell As Range Dim sRange As Range Dim shShape As Shape Dim OvName As String On Error GoTo DR_OVAL_Err Set sRange = Selection For Each cCell In Selection OvName = "oval" + cCell.AddressLocal If IsExistShape(OvName) Then If cCell.Value >= 60 Then ActiveSheet.Shapes(OvName).Delete End If Else If cCell.Value < 60 Then Set shShape = ActiveSheet.Shapes.AddShape(msoShapeOval, cCell.Left, cCell.Top, cCell.Width, cCell.Height) With shShape .Name = OvName .Fill.Transparency = 1# .Line.ForeColor.SchemeColor = 10 End With End If End If Next Set cCell = Nothing Set sRange = Nothing Exit Sub DR_OVAL_Err: MsgBox Err.Error Err.Clear Resume Next End Sub Function IsExistShape(ShapeName As String) As Boolean Dim shShape As Shape IsExistShape = False For Each shShape In ActiveSheet.Shapes If shShape.Name = ShapeName Then IsExistShape = True Exit Function End If Next shShape End Function