ارجو المساعدة بكود لنسخ محتويات التعليق داخل خلية

[فضل حسين]

الى خبراء واعضاء منتداى العزيز والعظيم

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

مرفق ملف موضح به المطلوب

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

نسخ محتويات التعليق داخل خلية.rar

[الـعيدروس]

السلام عليكم

جرب هذا الكود

Sub ALIDROOS_CP()

On Error Resume Next

Set ALI_P = Range("A1:A50")

For Each C_ALI In ALI_P

If C_ALI.Comment.Text = "" Then

Else

B_ALI = Mid(C_ALI.Comment.Text, InStr(C_ALI.Comment.Text, ":"), Len(C_ALI.Comment.Text) - InStr(C_ALI.Comment.Text, ":"))

End If

If InStr(B_ALI, vbLf) <> 0 Then

T_A = Split(B_ALI, vbLf)

For I = 0 To UBound(T_A)

Range("C" & Cells(Rows.Count, 3).End(xlUp).Offset(1, 0).Row).Value = T_A(I)

Next

End If

B_ALI = ""

T_A = ""

Next

Set ALI_P = Nothing

On Error GoTo 0

End Sub

[الزير]

الأستاذ المميز أبونصار هل أحصل بغدادنك على شرح لهذه الأسطر

B_ALI = Mid(C_ALI.Comment.Text, InStr(C_ALI.Comment.Text, ":"), Len(C_ALI.Comment.Text) - InStr(C_ALI.Comment.Text, ":"))

وهذه

T_A = Split(B_ALI, vbLf)

For I = 0 To UBound(T_A)

[عبدالله باقشير]

السلام عليكم

بعد اذن حبيبي ابو انصار حفظه الله

ولاثراء الموضوع

تم تعديل شويه في الكود

Sub kh_AddTextCRang()

Dim T_A

Dim C_ALI As Range

Dim B_ALI As String

For Each C_ALI In Range("A1:A50")

    If Not C_ALI.Comment Is Nothing Then

        B_ALI = Trim(C_ALI.Comment.Text)

        For Each T_A In Split(B_ALI, vbLf)

            Range("H" & Cells(Rows.Count, "H").End(xlUp).Offset(1, 0).Row).Value = Trim(T_A)

        Next

    End If

Next

End Sub

Split

دالة تحول النص الى جدول حسب فاصل معين

الفاصل الافتراضي للدالة " "

ترتيب الجدول من الصفر الى عدد القيم المحصلة-1

LBOUND=0

UBOUND=عدد القيم المحصلة-1

ودمتم

[abouelhassan]

الاساتذة خبور خير - ابو نصار

احترام من كل قلبى لهذه الروائع

بارك الله لكما وبكما أمين

[الـعيدروس]

السلام عليكم

اين ماحللتم ابدعتم جزاك الله خير استاذ عبدالله

فكرت الكود كما تفضل استاذنا الحبيب عبدالله خبور خير

استخدام دالة MID و LEN و INSTR لحفظ موقع السطر

ودالة SPLIT لتحديد الفراغ من جميع السطور وحفظه في المتغير

وثم سرده عن طريق الحلقة التكرارية

من اول فراغ For I = 0 To UBound(T_A) وانت رايح في عمود C

هذا والله اعلم

[فضل حسين]

الى الاساتذة الفضلاء الكبار

الاستاذ الرائع الكبير / ابو نصار

العلامة الكبير / خبو خير

عمل رائع بارك الله فيكم وجزاكم الله كل خير وعلى ماتقدموه من خير وعلم للجميع . جعله الله فى ميزان حسناتكم اللهم امين .

ولكن ليكتمل العمل وليحقق المطلوب منه بالكامل يوجد ملحوظة بسيطة اوضحتها بالملف المرفق ارجو المساعدة فى حلها .

ولايسعنى فى النهاية الا ان اشكر سيادتكم شكرا جزيل

وفى انتظار روائعكم وردودكم الجميلة

كود نسخ تعليق.rar

تم تعديل ديسمبر 27, 2011 بواسطه فضل 1

[الـعيدروس]

على فهمي للتعديل بسيطه

جرب هكذا (كود العالم الفذ خبور خير)

Sub kh_AddTextCRang()

Dim T_A

Dim C_ALI As Range

Dim B_ALI As String

For Each C_ALI In ActiveCell

    If Not C_ALI.Comment Is Nothing Then

	    B_ALI = Trim(C_ALI.Comment.Text)

	    For Each T_A In Split(B_ALI, vbLf)

		    Range("H" & Cells(Rows.Count, "H").End(xlUp).Offset(1, 0).Row).Value = Trim(T_A)

	    Next

    End If

Next

End Sub

[عبدالله المجرب]

السلام عليكم

هذا تعديل لكود العلامة خبور

Sub kh_AddTextCRang()

Dim T_A

Dim B_ALI As String

    If Not ActiveCell.Comment Is Nothing Then

	    B_ALI = Trim(ActiveCell.Comment.Text)

	    For Each T_A In Split(B_ALI, vbLf)

		    Range("H" & Cells(Rows.Count, "H").End(xlUp).Offset(1, 0).Row).Value = Trim(T_A)

	    Next

    End If

End Sub

[الـعيدروس]

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

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

بيكون الكود بهذ الشكل استخدمنا SELECTION للتحديد الحر

Sub kh_AddTextCRang()

Dim T_A

Dim C_ALI As Range

Dim B_ALI As String

For Each C_ALI In Selection

	If Not C_ALI.Comment Is Nothing Then

		B_ALI = Trim(C_ALI.Comment.Text)

		For Each T_A In Split(B_ALI, vbLf)

			Range("H" & Cells(Rows.Count, "H").End(xlUp).Offset(1, 0).Row).Value = Trim(T_A)

		Next

	End If

Next

End Sub

تم تعديل ديسمبر 27, 2011 بواسطه alidroos

[فضل حسين]

ايه العظمة دى كلها وايه الجمال ده كله

انا اليوم سعيد الحظ بهذه المشاركة التى اعتبرها تاريخية . لان تجمع فيها العظماء والخبراء . اساتذتنا الكبار قوى قوى قوى

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

وفى لحظة كتابة هذه المشاركة بان اقف وارفع القبعة وتعظيم سلام لمدة دقيقة لكل الاساتذة الكبار على كل مايقدموه لكل من

الرائع الكبير ابو نصار

العلامة الكبير خبو خير

المايسترو حبيب قلبى

وعلى فكرة بعد ماقمت بعمل تعظيم سلام امام جهاز الكمبيوتر اولادى استغربوا وقالوا هو فيه ايه . قلتلهم من علمنى حرفى سر له عبدا .

اجمل المنى وارق التهانى لكم وللجميع

تم تعديل ديسمبر 27, 2011 بواسطه فضل 1

[عبدالله المجرب]

السلام عليكم

اخي فضل

شكراً على كل هذا الكلام الجميل

وانا اقف معك وارفع القبعة احتراماً للاستاذان الفاضلان

العيدروس

وخبور خير

فانا لم اقم الا بتعديل لا يذكر لكود احترافي بدائه العيدروس وختمه العلامة خبور