موضع العمود الأيمن والأيسر لأي شكل في ورقة العمل

[moh250]

السلام عليكم 

اليكم شيت مرفق بية عدد 2 شيب , انا اريد عندما احدد الشيب يذهب الي الشيت رقم 2 و يكتب محتوى الشيب فى العمود الاول ( MOHAMED ) و العمود الثانى يكتب مكان وقفة يمين فيكتب الرقم 1000 و العمود لثالث مكان وقفة شمال 700

WORK.rar

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

على أي أساس اخترت الأرقام 1000 و 700

يرجى مزيد من التوضيح

وماذا لو ضغطت على الشكل مرة أخرى ما المتوقع ؟؟ وماذا لو ضغطت على الشكل المكتوب عليه Aly ما النتائج المتوقعة

[moh250]

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

اولا : انا اخترت الرقم 1000 عل اساس مكان حدود الشيب اليمين و الرقم 700 عل اساس مكان حدود الشيب الشمال

ثانيا : لو ضغط على الشكل مرة اخرى حيذهب الي الشيت رقم 2 وحينزل صف و يكتب نفس البيانات محتوى الشيب فى العمود الاول ( MOHAMED ) و العمود الثانى يكتب مكان وقفة يمين فيكتب الرقم 1000 و العمود لثالث مكان وقفة شمال 700

ثالثا : لو ضغط على الشكل ALY حيذهب الي الشيت رقم 2 وحينزل صف و يكتب محتوى الشيب فى العمود الاول ( ALY ) و العمود الثانى يكتب مكان وقفة يمين فيكتب الرقم 1700 و العمود لثالث مكان وقفة شمال 1400

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

أخي الكريم

يرجى تغيير اسم الظهور للغة العربية ويرجى الإطلاع على رابط التوجيهات في الموضوعات المثبتة في المنتدى لكيفية التعامل مع المنتدى بشكل جيد

 

إليك الكود التالي عله يفي بالغرض

Sub TestRun()
    Dim SHP As Shape, strX As String
    Dim lColLeft As Long, lColRight As Long
    Dim LR As Long

    Application.ScreenUpdating = False
        With Sheet1.Shapes(Application.Caller)
            If Mid(.Name, 1, 9) = "Rectangle" Then
                strX = Mid(.TextFrame.Characters.Text, InStr(.TextFrame.Characters.Text, ": ") + 2)
                lColLeft = .TopLeftCell.Column: lColRight = .BottomRightCell.Column
                With Sheet2
                    LR = .Cells(Rows.Count, 1).End(xlUp).Row + 1
                    .Range("A" & LR).Value = strX
                    .Range("B" & LR).Value = Sheet1.Cells(2, lColRight).Value
                    .Range("C" & LR).Value = Sheet1.Cells(2, lColLeft).Value
                End With
            End If
        End With
    Application.ScreenUpdating = True
End Sub

يتم ربط الشكل بالكود عن طريق كليك يمين ثم Assign Macro ثم اختيار اسم الماكرو TestRun

 

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

تقبل تحياتي وتوجيهاتي

Application Caller & Shapes YasserKhalil.rar

[moh250]

لك كل الشكر اخى ياسر

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

أخي الفاضل يرجى الإطلاع على رابط التوجيهات من هنا

 

يرجى تحديد أفضل إجابة والضغط على كلمة أعجبني هذا إذا أعجبك المحتوى

لم تستجب لتغيير اسم الظهور للغة العربية