عمل خريطة لورقة العمل Quick Map

[ياسر خليل أبو البراء]

السلام عليكم ورحمة الله وبركاته

إخواني الأحباب في المنتدى الأغر ..

أقدم لكم كود في منتهى الروعة ، يقوم بعمل خريطة (ليست الخريطة التي في مخيلتكم .. أنا معلم لغة إنجليزية ولست معلم دراسات اجتماعية)

الكود يعتمد على إنشاء ورقة عمل جديدة .. لبدء العمل فيها بناءً على ورقة العمل النشطة التي يتم تنفيذ الكود بها ..

ورقة العمل الجديدة تحتوي على خلايا ملونة وداخلها رموز .. للتعرف على القيم الرقمية والنصوص والمعادلات الموجودة داخل ورقة العمل النشطة ..

'وتلوينها باللون الأصفر[N]يتم ترميز الخلايا التي تحتوي على قيم رقمية بالرمز
' وتلوينها باللون الأخضر[T]يتم ترميز الخلايا التي تحتوي على قيم نصية بالرمز
'وتلوينها باللون الأحمر[F]بالرمز[Formulas]يتم ترميز الخلايا التي تحتوي على معادلات

ويوضع الكود داخل موديول بهذا الشكل

Sub QuickMap()
    If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub

'Create object variables for cell subsets    إنشاء متغيرات للكائنات التي تمثل مجموعات الخلايا
    On Error Resume Next
    Set FormulaCells = Range("A1").SpecialCells _
      (xlFormulas, xlNumbers + xlTextValues + xlLogical)
    Set TextCells = Range("A1").SpecialCells(xlConstants, xlTextValues)
    Set NumberCells = Range("A1").SpecialCells(xlConstants, xlNumbers)
    On Error GoTo 0

'Add a new sheet and format it    إنشاء ورقة عمل جديدة وعمل تنسيق لها
    Sheets.Add
    With Cells
        .ColumnWidth = 2
        .Font.Size = 8
        .HorizontalAlignment = xlCenter
    End With
    
    Application.ScreenUpdating = False

'Do the formula cells   التعامل مع الخلايا التي تحتوي على معادلات
    If Not IsEmpty(FormulaCells) Then
        For Each Area In FormulaCells.Areas
            With ActiveSheet.Range(Area.Address)
                .Value = "F"
                .Interior.ColorIndex = 3
            End With
        Next Area
    End If
   
'Do the text cells   التعامل مع الخلايا التي تحتوي على نصوص
    If Not IsEmpty(TextCells) Then
        For Each Area In TextCells.Areas
            With ActiveSheet.Range(Area.Address)
                .Value = "T"
                .Interior.ColorIndex = 4
            End With
        Next Area
    End If
    
'Do the numeric cells   التعامل مع الخلايا التي تحتوي على قيم رقمية
    If Not IsEmpty(NumberCells) Then
        For Each Area In NumberCells.Areas
            With ActiveSheet.Range(Area.Address)
                .Value = "N"
                .Interior.ColorIndex = 6
            End With
        Next Area
    End If
End Sub

فائدة الكود تكمن في إمكانية التعرف على الأخطاء التي يمكن أن تتواجد في ورقة العمل .. .

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

 

أتمنى أن ينال الملف المرفق رضاكم ، وأن تستفيدوا منه إن شاء الله عزوجل

تقبلوا تحياتي القلبية ، ودمتم على طاعة الله

 

Quick Map VBA.rar

 

[شوقي ربيع]

السلام عليكم

حلوة الحركة اخي ياسر

يمكن استعمالها في اكثر من مجال

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

هذا الكود سيساعدني شخصيا على الوصول السريع الى ما ابحث عنه

ملاحظة بسيطة

لو تعدل الكود بحيث تكون الخريطة في ورقة ثابة بدلا من انشاء ورقة جديدة كل مرة

وايضا ان تربطه بغلق الملف مع الحفظ ليكون الامر اوتوماتيكيا بدل الزر

تحياتي لك اخي ياسر

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

[ياسر خليل أبو البراء]

الأخ الحبيب شوقي ربيع

بارك الله فيك ومشكور على مرورك العطر ..

الملف لديك افعل به ما بدا لك وطوره كفيما شئت ، وأكيد نحن أول المستفيدين ..

تقبل تحياتي القلبية أخي وأستاذي الكبير شوقي

[محي الدين ابو البشر]

مشكور استاذ ياسر على ابداعك

بارك الله فيك وجعله في ميزان حسناتك

[Yasser Fathi Albanna]

رائـــــــــــــــــــــــــــــــــــــــــــــــــع أخى الفاضل أبو البراء

[ياسر خليل أبو البراء]

بارك الله فيك أخي العزيز محي الدين وجزيت خيراً

الأروع هو مرورك أخي الحبيب ياسر البنا ..

عفواً لم أنتبه لردودكم إلا الآن ..

 

[saad abed]

اخى ابوالبراء

افكارك جميله ومفيده

بارك الله فيك

[محمد حسن المحمد]

السلام عليكم

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

 

[ياسر خليل أبو البراء]

أخي الكريم سعد عابد

مشكور على مرورك الكريم بالموضوع وجزاك الله خيراً

 

وعليكم السلام أخي الحبيب أبو يوسف

بارك الله فيك وجزيت خيراً على مرورك العطر بالموضوع ، والمميز هو مرروك أخي الغالي

[أبوبسمله]

جزاك الله كل خير يا ابو البراء

هى دى طريقة الخريطه اللى كنت بتحكيلى عليه بالتليفون ؟

[ياسر خليل أبو البراء]

دي خريطة تانية .. خريطة الوطن العربي!

خريطة ايه اللي اتكلمت عليها .. أنا مش فاكر ! فكرني عشان عندي زهايمر

[أبوبسمله]

خريطه اللى بتسهل عليك كتابة الاكواد لما بتحب تعدل على كود معين

 

سلامتك من الهاميمر

بعد الشر ياغالى بلاش تقول الفال ده

المهم افتح الفيس وكلمنى هناك قشطه

[ابو القبطان]

استاذ .. وفنان .. ومبدع كما عودتنا

[ياسر خليل أبو البراء]

أخي الحبيب جدو العزيز

مشكور على مرورك العطر بالموضوع ونورت المنتدى بعد طوووووووووووووووووووول غياب