الـعيدروس

الاخ الفاضل سامر الانباري الشرح غير واضح مزيد من التوضيح حفظك الله

مشكور استاذ عبدالله على المشاركة القيمة واعتقد ان طلبة على الخلايا المحددة بالماوس او العمود بيكون الكود بهذ الشكل استخدمنا 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

على فهمي للتعديل بسيطه جرب هكذا (كود العالم الفذ خبور خير) 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

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

جزاك الله خير ولاكن ربما نسيت ترفق البرنامج

السلام عليكم اين ماحللتم ابدعتم جزاك الله خير استاذ عبدالله فكرت الكود كما تفضل استاذنا الحبيب عبدالله خبور خير استخدام دالة MID و LEN و INSTR لحفظ موقع السطر ودالة SPLIT لتحديد الفراغ من جميع السطور وحفظه في المتغير وثم سرده عن طريق الحلقة التكرارية من اول فراغ For I = 0 To UBound(T_A) وانت رايح في عمود C هذا والله اعلم

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

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

جرب هذا الكود هو للورقة النشطة لاني عكيت على كافة الاوراق مازبطت معي دالة التكرار لي محاولة اخرى ان شاء الله Private Sub CommandButton1_Click() Dim ALI_D As Range, ALI_R As Range Dim go As String GO1 = InputBox("إدخل الكلمة المراد حذف الصفوف", "منتدى أوفسينا") If GO1 = "False" Or GO1 = vbNullString Then Exit Sub On Error Resume Next If vbYes Then Set ALI_D = ActiveSheet.Range("B2:B500") For Each ALI_R In ALI_D.Rows If Not ALI_R.Find(what:=GO1, LookIn:=xlValues, lookat:=xlWhole) Is Nothing Then ALI_R.Select If MsgBox("هل تريد حذف هذه النتيجة", vbOKCancel, "تحذير !!!") = vbOK Then ActiveCell.EntireRow.Delete End If End If Next ALI_R End If End Sub

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

السلام عليكم حط هذا الكود Private Sub TextBox25_Change() If TextBox25.Value <> Empty Then TextBox27.Value = "رصيد الأمانات" ElseIf TextBox25.Value = Empty Then TextBox27.Value = "" End If End Sub

لو ترفق مثال وعليه شرح مبسط ان شاء الله نتوصل لما تريد

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

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

السلام عليكم جرب هذا الكود امل ان يفي بالغرض Public Sub ALIDROOS() On Error Resume Next Dim X As Range, XX As Range, XXX As Range Set X = Range("B1:B100") For Each XX In X If XX.Value <> Empty Then XX.Offset(0, 1).Value = CDbl(XX) - CDbl(100 / 100) XXX.Value = XX.Offset(0, 1).Value = CDbl(XX) - CDbl(100 / 100) XX.Offset(0, 2).Value = CDbl(XXX) * CDbl(XX.Offset(0, -1).Value) End If Next XX End Sub

السلام عليكم جرب هذا الكود 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

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

ممكن ترفق الملف كي اتفحص مالمشكلة وارفقة لك بعد التعديل اذا تكرمت او مثال وعليه الفورم

السلام عليكم جرب حط هذا السطر قبل الأكواد Public DD, COL, M ان شاء الله يزبط معاك تحياتي

السلام عليكم اشكرك استاذ عبدالله على هذا المرور العطر ومروركم شرف كبير لنا ونعتز به

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

السلام عليكم جرب هذا الكود Const T_A = "منتدى أوفسينا " Const M_A = "قم بإدخال القيمة المراد حذف الصفوف من كافة الأوراق" Sub ALIDROOS_DE_ALL() Dim S As Worksheet Dim i As Long Dim ALI_T As Variant Dim Q As String Dim ALI_F As Range ALI_T = InputBox(prompt:=M_A, Title:=T_A) If MsgBox("سيتم حذف جميع الكلمات المطابقة من كل الأوراق", vbOKCancel, "تحذير !!!") = vbOK Then If ALI_T = "" Then Exit Sub Application.ScreenUpdating = False For Each S In ThisWorkbook.Worksheets For i = S.Cells.SpecialCells(xlCellTypeLastCell).Row To 1 Step -1 Set ALI_F = S.Rows(i).Find(what:=ALI_T, LookIn:=xlValues, lookat:=xlWhole) If Not ALI_F Is Nothing Then S.Rows(i).Delete Next Next Q = ALI_T MsgBox Q & vbNewLine & "^====" & " تم حذف الصفوف التي وجد فيها هذه الكلمة من كافة الأوراق " & "بنجاح" Else MsgBox "تم إلغاء العملية" Exit Sub End If Application.ScreenUpdating = True End Sub

السلام عليكم بالنسبة للرسالة تعتبر كشخه فقط ولا يهمك ياعم اكشخ براحتك هذا الكود Sub ALidroos_CP_S() Dim A_R As Range, ALI_R As Range CreateObject("Wscript.shell").Popup "إنتظر قليلاً حتى الإنتهاء من معالجة البيانات", 1, "إنتظار !!!!", vbExclamation Set ALI_R = Range("A2:A86") For Each A_R In ALI_R A_R = Trim(WorksheetFunction.Substitute(A_R, "-", "")) A_R = Trim(WorksheetFunction.Substitute(A_R, "_", "")) Next CreateObject("Wscript.shell").Popup "تمت معالجة البيانات بنجاح", 5, "تمت العملية والحمد لله ", vbInformation End Sub جرب وبلغنا بالنتائج تحياتي

السلام عليكم اشكرك جدا استاذ عماد على هذا التشجيع وجزاك الله خير على اكوادك نتعلم الكثير منك حفظك الله وسدد خطاك تلميذك أبو نصار

السلام عليكم بعد تحايل توصلت لهذا الكود استبدل الكود التالي بالكود الذي عندك Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Excel.Range) Static OldCell As Range Application.EnableEvents = False Call ali_COLR Application.EnableEvents = True If Not OldCell Is Nothing Then OldCell.Interior.Color = xlColorIndexNone End If Application.EnableEvents = False Call ali_COLR Application.EnableEvents = True Target.Interior.Color = 3 Set OldCell = Target End Sub والتنسيق الشرطي الغية سيقوم بعملة هذا الكود حط الكود في مودويل Public Sub ali_COLR() Dim R For R = 1 To 50 Range(Cells(R, 1), Cells(R, 18)).Offset(1, 0).Interior.Color = RGB(210, 242, 250) R = R + 1 Next End Sub جرب واخبرني بالنتائج تحياتي