کشیده شدن دایره قرمز دور سلول

Collapse
X
 
  • زمان
  • Show
Clear All
new posts
  • mostafap4

    • July 2010
    • 192

    کشیده شدن دایره قرمز دور سلول

    با سلام
    میخواستم ببینم میشه با ماکرو نویسی کدی نوشت که اگر سلولی شرط if ما را رعایت نکرده بود دور آن دایره ای مثلا قرمز رنگ ترسیم شود؟
    ممنون میشم راهنمایی کنید
    فقر شب را "بی غذا" سر کردن نیست ... فقر روز را "بی اندیشه" سر کردن است !
  • m_d6712

    • May 2010
    • 174

    #2
    RE: کشیده شدن دایره قرمز دور سلول

    با سلام!
    برای این کار کد زیر را در Codeview شیت مورد نظر کپی کنید. شرطی که من در نظر گرفتم بزرگتر بودن عدد از 10 می باشد. یعنی هر عددی بزرگتر از 10 در هر سلولی وارد کردید دور آن سلول یک دایره رسم می کند.


    Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Value > 10 Then
    Sheet1.Shapes.AddShape msoShapeOval, Target.Left - 5, Target.Top - 5, Target.Width + 10, Target.Height + 10
    Sheet1.Shapes(Sheet1.Shapes.Count).Fill.Transparen cy = 1
    Sheet1.Shapes(Sheet1.Shapes.Count).Line.ForeColor. RGB = 255
    End If
    End Sub


    برای کمک فایل رو هم آپلود کردم: http://www.mediafire.com/file/010lmnlnda1lkm8/ovalAroundCell.xlsm
    -------
    http://md6712.com
    جامعه ایده پردازان: http://idekadeh.com

    Comment

    • khakzad

      • March 2010
      • 2034

      #3
      RE: کشیده شدن دایره قرمز دور سلول

      با تشکر از دوست عزیز آقای داوری
      کد خیلی قشنگیه.
      اما خوب، این در صورت تغییر دادن یک سلول به مقدار قابل قبول برای شرط، دایره سر جاش می مونه! که البته قطعا راه حلی براش دارید.
      اما می تونیم از data validataion هم استفاده کنیم.اینطوری شرط رو هم به راحتی تغییر میدیم. و هر بار با زدن کلید circle invalid data اطلاعات خارج از رنج رو مشخص می کنه
      [hr]
      و البته شیت ما تعداد shape ها زیاد نمیشه!!!
      موفق باشید

      Comment

      • mostafap4

        • July 2010
        • 192

        #4
        RE: کشیده شدن دایره قرمز دور سلول

        سلام
        ممنونم
        خدمت دوست خوبم آقای خاکزاد عرض کنم که با دیتا ولیدیشن نمیشه شرط مانند if گذاشت ولی با این کدی که آقای داوری فرمودند بنظرم میشه و هنوز امتحان نکردم ولی میش به احتمال زیاد
        ممنونم دوستان
        فقر شب را "بی غذا" سر کردن نیست ... فقر روز را "بی اندیشه" سر کردن است !

        Comment

        • khakzad

          • March 2010
          • 2034

          #5
          RE: کشیده شدن دایره قرمز دور سلول

          البته.منم برای حالت های ساده گفتم.یه جورایی تبدیل if به عبارت های ساده.اما در کل کد آقای داوری جامع تر هست
          موفق باشید.

          Comment

          • m_d6712

            • May 2010
            • 174

            #6
            RE: کشیده شدن دایره قرمز دور سلول

            سلام!
            البته این روش یک مقدار غیر استاندارد هم هست! شما اگر بخواهید می توانید به راحتی از Property های خود سلول استفاده نمایید. یعنی Border و forecolor یا Interior یا هر Property دیگر که جهت تمیز دادن بشه به آن اتکا کرد. اما هیچ راهی برای ایجاد Oval یا بیضی و دایره با استفاده از Property سلول وجود ندارد. که برای این کار مجبور هستیم از Shape استفاده نماییم.
            در صورتی که شکل اهمیت خاصی ندارد و فقط تمیز دادن برای شما مهم است بهتر است از روش Property سلول استفاده نمایید.


            اما در مورد دایره و در مورد سوال خانم خاکزاد:
            منتظر این سوالتون بودم. این هم راحل داره! این کد رو جایگزین کد قبل کنید:

            [align=left]
            کد:
            Private Sub Worksheet_Change(ByVal Target As Range)
            If IsNumeric(Target.Text) Then
               If Target.Value > 10 Then
                    Sheet1.Shapes.AddShape msoShapeOval, Target.Left - 5, Target.Top - 5, Target.Width + 10, Target.Height + 10
                    Sheet1.Shapes(Sheet1.Shapes.Count).Fill.Transparency = 1
                    Sheet1.Shapes(Sheet1.Shapes.Count).Line.ForeColor.RGB = 255
                Else
                    For Each Shape In Sheet1.Shapes
                        If Shape.Left = Target.Left - 5 And Shape.Top = Target.Top - 5 Then
                            Shape.Delete
                            Exit For
                        End If
                    Next
                End If
            Else
                For Each Shape In Sheet1.Shapes
                    If Shape.Left = Target.Left - 5 And Shape.Top = Target.Top - 5 Then
                         Shape.Delete
                       Exit For
                    End If
                Next
            End If
            End Sub
            [/align]

            درست همون چیزی که انتظار دارید اتفاق می افته!
            -------
            http://md6712.com
            جامعه ایده پردازان: http://idekadeh.com

            Comment

            • khakzad

              • March 2010
              • 2034

              #7
              RE: کشیده شدن دایره قرمز دور سلول

              خیلی جالب بود.
              ممنون.

              Comment

              • mostafap4

                • July 2010
                • 192

                #8
                RE: کشیده شدن دایره قرمز دور سلول

                با سلام
                یک سوال چه کدی قبلش اضافه کنیم که قبل از اینکه شروع به چک کردن شرط کنه همه ی داده ها را از وجود بیضی پاک کنه و سپس مجددا شروع به کشیدن بیضی کنه؟
                فقر شب را "بی غذا" سر کردن نیست ... فقر روز را "بی اندیشه" سر کردن است !

                Comment

                • ariyo

                  • September 2010
                  • 35

                  #9
                  RE: کشیده شدن دایره قرمز دور سلول

                  با سلام به همه ی دوستان
                  همانطور که همه میدونید این کار زیاد استاندارد نیست چون بسته به نوع کار و اندازه ها و تعداد اعداد زیاد مطلوب به نظر نمی رسه. به نظر بنده اگر از Validation تنها استفاده بشه خیلی بهتره. یا اینکه از Validation در قالب کد استفاده بشه.
                  اما اگر الزام به دایره کشیدن باشه، میشه تحت یک ماکرو که بوسیله کاربر فراخوانی بشه و حتی پارامترهای رسم را هم بشوه وارد کرد در نظر گرفت. فکر می کنم به این شکل زیباتر بشه و کار از شلوغی در بیاد.
                  اما از m_d6712 و khakzad به دلیل توجه و پیگیریشون کمال تشکر رو دارم.
                  چون کوه به خود سپه شکن باش *** فرزند خصال خویشتن باش

                  Comment

                  • ariyo

                    • September 2010
                    • 35

                    #10
                    RE: کشیده شدن دایره قرمز دور سلول

                    با عرض سلام مجدد
                    برای اینکه امکان رسم دایره بصورت دلخواه باشه. من کدی آماده کرده ام که شما می توانید با استفاده از اون یک منوی Right-Click داشته باشید و روی هر سلول که کلیک راست کنید و گزینه Draw Shape رو انتخاب کنید، یک بیضی قرمز رنگ روی همان سلول رسم کنه.
                    کد از دو قسمت تشکیل شده.
                    1- ابتدا کد زیر زا در قسمت کد ThisWorkbook قرار دهید.

                    Private Sub Workbook_Deactivate()
                    On Error Resume Next
                    With Application
                    .CommandBars("Cell").Controls("My Macro").Delete
                    End With
                    On Error GoTo 0
                    End Sub

                    Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
                    Dim cBut As CommandBarButton
                    On Error Resume Next
                    With Application
                    .CommandBars("Cell").Controls("Draw Shape").Delete
                    Set cBut = .CommandBars("Cell").Controls.Add(Temporary:=True)
                    End With
                    With cBut
                    .Caption = "Draw Shape"
                    .Style = msoButtonCaption
                    .OnAction = "draw_shape"
                    End With
                    On Error GoTo 0
                    End Sub

                    2- حالا یک ماژول به پروژه اضافه نموده و سپس کد زیر را در داخل آن کپی نمایید.

                    Sub draw_shape()
                    Dim intleft As Integer, inttop As Integer, intwidth As Integer, intheight As Integer

                    With Selection
                    .HorizontalAlignment = xlCenter
                    .VerticalAlignment = xlCenter
                    End With

                    intleft = Selection.Left - 5
                    inttop = Selection.Top - 5
                    intwidth = Selection.Width + 10
                    intheight = Selection.Height + 10

                    With ActiveSheet.Shapes
                    .AddShape msoShapeOval, intleft, inttop, intwidth, intheight
                    End With
                    ActiveSheet.Shapes(ActiveSheet.Shapes.Count).Fill. Transparency = 1
                    ActiveSheet.Shapes(ActiveSheet.Shapes.Count).Line. ForeColor.RGB = 255
                    End Sub


                    حالا شما در داخل پروژه اگر روی سلول کلیک راست نمایید (در هر شیت که مایلید)، گزینه ی Draw Shape را خواهید دید و با انتخاب آن می توانید روی همان سلول یک دایره(بیضی) قرمز رنگ رسم نمایید.

                    فایل نمونه برای دانلود
                    http://www.4shared.com/file/csiM-94z/draw_oval.html

                    شاد و سلامت باشید
                    چون کوه به خود سپه شکن باش *** فرزند خصال خویشتن باش

                    Comment

                    • m_d6712

                      • May 2010
                      • 174

                      #11
                      RE: کشیده شدن دایره قرمز دور سلول

                      نوشته اصلی توسط ariyo
                      با سلام به همه ی دوستان
                      همانطور که همه میدونید این کار زیاد استاندارد نیست چون بسته به نوع کار و اندازه ها و تعداد اعداد زیاد مطلوب به نظر نمی رسه. به نظر بنده اگر از Validation تنها استفاده بشه خیلی بهتره. یا اینکه از Validation در قالب کد استفاده بشه.
                      با تشکر از کد خوب شما
                      این که استاندارد نیست رو کاملا موافقم.
                      این که استفاده از validation ها نیز خیلی راحت و کاربردیه نیز موافقم.
                      اما به نظر من validation محدودیت داره! بعضی وقتا نیاز هست که از این روش استفاده کنیم. برای مثال برای شرط های پیچیده.
                      استاندارد نبودن در استفاده از Shape است نه استفاده از VBA.
                      اگر به جای یک دایره از یک Border قرمز دور سلول بهره می گرفتیم خیلی راحت تر بود و حجم پردازشی کمتری داشتیم.

                      اما ابتدا بیایم دلیل استاندارد نبودن رو بگیم.
                      دلیل اینه که داریم یک شی خارج از اشیاء منظم و پشت سر هم داخل شیت (سلول ها)، برای یک سلول خاص ایجاد می کنیم. این چند ایراد داره:
                      1- بعد از این که شی ایجاد میشه برای پیدا کردن شی مشکلاتی داریم. زیرا ارتباط بین شی سلول و شی دایره وجود نداره. فقط هر دو عضوی از شی Datasheet می باشند. این کمی کار رو سخت می کنه! که این راه حل هایی داره. یعنی با برنامه نویسی قابل حل است.
                      2- از نظر مفهومی: اینکه بخواهیم یک شی رو مشخص کنیم و اون رو یک طوری متمایز کنیم داریم از یک شی خارجی کمک می گیریم که این در شی گرایی عیب محسوب میشه! هر شی باید برای بروز مشخصات خودش از مشخصه های (property) خودش استفاده کند. این به تنهایی مشکلی ایجاد نمی کند. اما در هر شی مشخصات زیادی وجود دارد که در ارتباط با یکدیگر می باشند. در داخل یک شی با تغییر یک مشخصه مشخصات دیگری نیز تغییر می کنند. که این وجه قضیه دردسر ساز می باشد.
                      برای حل مشلکل دوم هم راه حل کدنویسی وجود داره! افزودن کلاس های کمکی



                      برای اینکه امکان رسم دایره بصورت دلخواه باشه. من کدی آماده کرده ام که شما می توانید با استفاده از اون یک منوی Right-Click داشته باشید و روی هر سلول که کلیک راست کنید و گزینه Draw Shape رو انتخاب کنید، یک بیضی قرمز رنگ روی همان سلول رسم کنه.
                      کد بسیار خوبی بود و مفید. اما هنوز مشکلات بالا را دارد.
                      -------
                      http://md6712.com
                      جامعه ایده پردازان: http://idekadeh.com

                      Comment

                      • ariyo

                        • September 2010
                        • 35

                        #12
                        RE: کشیده شدن دایره قرمز دور سلول

                        با سلام خدمت دوست خوبم m_d6712
                        بنده کاملا با شما موافقم و اگر هم در مورد Validation گفته بودم، منظورم کارهای ساده بور وگرنه تمامی عرایض شما به حق است.
                        و از نقطه نظر مشکلات آبجکتی نیز توضیحاتتون کاملا درسته. من فکر می کنم که اینچنین استفاده ای شاید غیر استاندارد به نظر برسه. درسته که اکسل فوق العاده قوی هستش اما بالاخره هر نرم افزاری رو بهر کاری ساختند.
                        در پایان از اینکه من رو مورد لطف خودتون قرار دادید سپاسگزارم.

                        شاد و سربلند باشید.
                        چون کوه به خود سپه شکن باش *** فرزند خصال خویشتن باش

                        Comment

                        Working...