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

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

اضف هذا السطر آخر الكود If Not CC Is Nothing Then CC.EntireRow.Delete: Set CC = Nothing وسيعمل حسب طلبك الى ان اعدله بروية

السلام عليكم تم التعديل سريعا ساعدل الجزئية هذه

السلام عليكم بعد اذن حبيبي ابو انصار حفظه الله ولاثراء الموضوع تم تعديل شويه في الكود 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 ودمتم

السلام عليكم حبيبي ابو انصار ,,,, بوركت هذا التعديل على الكود ليقوم بالحذف Option Explicit Sub Kh_Find_All() Dim MyTextFind As Variant Dim MySh As Worksheet Dim C As Range, CC As Range Dim FirstAddress As String MyTextFind = Application.InputBox("اكتب ما تريد البحث عنه ؟", "بحث في جميع الاوراق الظاهرة") If MyTextFind = "" Or MyTextFind = False Then Exit Sub For Each MySh In ActiveWorkbook.Worksheets If MySh.Visible = xlSheetVisible Then With MySh.Cells Set C = .Find(MyTextFind, LookIn:=xlValues) If Not C Is Nothing Then FirstAddress = C.Address Do MySh.Activate C.Select '------------------------- If MsgBox("تم ايجاد قيمة البحث في العنوان" & Chr(10) & Chr(10) & MySh.Name & "!" & C.Address _ & Chr(10) & Chr(10) & "هل تريد حذف الصف ؟", 524288 + 1048576 + 4, "تاكيد") = 6 Then If CC Is Nothing Then Set CC = C Else Set CC = Union(CC, C) End If '------------------------- If MsgBox("هل تريد الاستمرار في البحث ؟", 524288 + 1048576 + 4, "تاكيد") = 7 Then GoTo 1 Set C = .FindNext(C) Loop While Not C Is Nothing And C.Address <> FirstAddress End If End With End If '----------------------------------------- If Not CC Is Nothing Then CC.EntireRow.Delete: Set CC = Nothing '----------------------------------------- Next MySh MsgBox IIf(Len(FirstAddress), "انتهى البحث", "لا توجد نتائج للبحث "), 524288 + 1048576, "بحث" 1: Set C = Nothing End Sub بحث بجميع الاوراق مع حذف نتيجة البحث.rar

السلام عليكم ده كود لي قديم للبحث في الاوراق ينفع ده للتعديل عليه لحذف الصف ؟؟؟ Option Explicit Sub Kh_Find_All() Dim MyTextFind As Variant Dim MySh As Worksheet Dim C As Range Dim FirstAddress As String MyTextFind = Application.InputBox("اكتب ما تريد البحث عنه ؟", "بحث في جميع الاوراق الظاهرة") If MyTextFind = "" Or MyTextFind = False Then Exit Sub For Each MySh In ActiveWorkbook.Worksheets If MySh.Visible = xlSheetVisible Then With MySh.Cells Set C = .Find(MyTextFind, LookIn:=xlValues) If Not C Is Nothing Then FirstAddress = C.Address Do MySh.Activate C.Select If MsgBox("تم ايجاد قيمة البحث في العنوان" & Chr(10) & Chr(10) & MySh.Name & "!" & C.Address _ & Chr(10) & Chr(10) & "هل تريد الاستمرار في البحث ؟", 524288 + 1048576 + 4, "تاكيد") = 7 Then GoTo 1 Set C = .FindNext(C) Loop While Not C Is Nothing And C.Address <> FirstAddress End If End With End If Next MySh MsgBox IIf(Len(FirstAddress), "انتهى البحث", "لا توجد نتائج للبحث "), 524288 + 1048576, "بحث" 1: Set C = Nothing End Sub اذا يناسبك سنقوم بذلك

السلام عليكم حبيبي ابو انصار------- حفظه الله انا تعمدت ان اسبقك بالحل فقد رايتك عملت بنصيحتك : افعل الخير مخلصا وإنتظر العائد يوما ساعة العُسرة امزح معاك بارك الله فيك

السلام عليكم بارك الله فيك اخي محمد صالح وبارك الله في اخي عبدالله جزاكما الله خيرا

السلام عليكم Sub KH_START() Dim i As Long For i = 2 To Range("A" & Rows.Count).End(xlUp).Row Cells(i, "C").Value = (100 - Val(Cells(i, "B"))) / 100 Cells(i, "D").Value = Val(Cells(i, "A")) * Val(Cells(i, "C")) Next End Sub تفضل المرفق DRY PRODUCTION.rar

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

السلام عليكم الاخ الفاضل بن عليه-----حفظه الله هل هذا ما تقصده ؟؟ Option Explicit Const RR As Integer = 157 Const CC As Integer = 26 Sub kh_SumProduct() Dim nAry() As Variant, mAry() As Variant, M_D() As Variant Dim MyCalc As XlCalculation Dim Last As Long, C As Integer, R As Integer, cN As Byte Dim Na As Range, Mo As Range, M As Range, D As Range On Error GoTo 1 '------------------------------------------ With Range("Name") Last = .Cells(.Rows.Count).End(xlUp).Row End With '------------------------------------------ Set Na = Range("Name").Resize(Last, 1) Set Mo = Range("Month").Resize(Last, 1) Set M = Range("Madine").Resize(Last, 1) Set D = Range("Daine").Resize(Last, 1) '------------------------------------------ ReDim nAry(1 To RR): ReDim mAry(1 To CC): ReDim M_D(1 To 2) '------------------------------------------ MyCalc = Application.Calculation Application.Calculation = xlCalculationManual Application.ScreenUpdating = False '------------------------------------------ M_D(1) = Kh_RgToAry(M): M_D(2) = Kh_RgToAry(D) '------------------------------------------ With Sheet4 For C = 1 To CC If C Mod 2 = 1 Then cN = 1 Else cN = 2 For R = 1 To RR If R = 1 Then mAry(C) = Kh_RgToAry(Mo, 1, .Cells(1, C + 2)) If C = 1 Then nAry(R) = Kh_RgToAry(Na, 1, .Cells(R + 3, 2)) .Cells(R + 3, C + 2) = WorksheetFunction.SumProduct(nAry(R), mAry(C), M_D(cN)) Next Next End With 1: Application.Calculation = MyCalc Application.ScreenUpdating = True '------------------------------------------ Erase nAry: Erase mAry Set Na = Nothing: Set Mo = Nothing: Set M = Nothing: Set D = Nothing End Sub Function Kh_RgToAry(MyRng As Range, Optional T As Variant, Optional Test As Variant) Dim co As Range, i As Long, Tb As Boolean ReDim MyAr(1 To MyRng.Cells.Count) For Each co In MyRng.Cells i = i + 1 If IsMissing(T) Or IsMissing(Test) Then MyAr(i) = CDbl(co) Else Select Case Val(T) Case 1: Tb = co = Test Case 2: Tb = co <> Test Case 3: Tb = co > Test Case 4: Tb = co < Test End Select MyAr(i) = Abs(CInt(Tb)) End If Next Kh_RgToAry = MyAr Erase MyAr End Function شاهد المرفق kh_SumProduct.rar ودمتم في حفظ الله

السلام عليكم في المرفق استخدمت صورة للاحرف ,, وذلك لضبط مساحة الحرف بشكل ادق وجعلت نصيبا للغة العربية اضفنا فورم آخر للاحرف بالعربي ويجب ان انبه ان هذا العمل ليس للاحرف فقط ممكن ان يكون لاي شي اخر المهم ان نستوعب هذه المراحل والخطوات عمل تطبيقي: تغيير الصورة للفورم الانجليزي بخط آخر وتكبير مساحة الحرف الاكواد في هذا المرفق سهله جدا وممكن تغيير عرض مساحة الحرف في بداية الكود عمل صورة بسيط جدا من نفس الشيت ورقة 2 سترى الخلايا التي عملت فيها صورة للاحرف العربية تعمل مثلها ولكن انجليزي تعمل نسخ للخلايا وتضعها في الرسام وتحفظها ثم تستبلها بالصورة السابقة في ImageChEng منتظر كم ودمتم في حفظ الله بحث بالاحرف.rar

السلام عليكم اخي الحبيب/ الخالدي --------------حفظه الله بارك الله فيك وجزاك الله خيرا ليس اعتقاد وانما هو ماقلته بيانا صحيحا 100% افرحكم الله مثل ما افرحتموني تقبلوا تحياتي وشكري وتقديري

السلام عليكم اخي الحبيب معتصم محمد ------------حفظه الله شكرا جزيلا وجزاك الله خيرا وبارك الله فيك على هذا الشرح المفصل وحقيقة فرحت كثيرا لاستيعابكم العمل وتقديمه بهذا الشرح الوافي اود ان اضيف شيئا بسيطا ان عرض الفورم ليس له علاقة باي شي ما دام انه يحتوي LabelABC بجميع عرضه وطوله المهم عندنا ضبط عرض LabelABC مع عدد الحروف مضروبه في العرض المخصص لهذا الحرف عرض LabelABC=عدد الحروف x عرض مساحة الحرف ان عملية الكتابة في LabelABC قد لا تضبط عرض مساحة الحرف ولكن قد استخدمت صورة للارقام بمساحة معينة للرقم في المرفق اللاحق شكرا جزيلا مرة اخرى تقبل تحياتي وتقديري

السلام عليكم اخي الحبيب سعد عابد ------------حفظه الله الله يسلمك في الدنيا والآخرة شكرا جزيلا على الكلام الطيب بارك الله فيك وجزاك الله خيرا بالنسبة لوظيفة INT تقريب رقم لأسفل إلى أقرب عدد صحيح. انا استخدمتها هنا لاقطع الرقم العشري بتاتا ولكن قد يطرح هذا السؤال لماذا تستخدم INT مادمت انك قد عرفت ان المتغير i هو رقم صحيح ؟؟ اقول ان الرقم الصحيح الناتج سيكون مقرب الى الاعلى في حالة وصل الرقم العشري الى 50% وانا اريد اقتصاص الرقم العشري من اصله. وهذا مثال بالكود : Sub kkkk() Const x As Integer = 23.5 MsgBox x End Sub النتيجة حتكون 24 وما اريده 23 تقبل تحياتي وشكري

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

السلام عليكم الرسالة هذه فعلا كشخة (رائعة) من شخص رائع بارك الله فيك

السلام عليكم شاهدوا هذا العمل خطوة خطوة لو كانت عند احدكم صورة للاحرف على شكل صف بتساوي المسافات فيما بينها حيكون افضل وسيتم اختصار الكود Private Sub LabelABC_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) Dim Lft!, i% i = Int(X / 14) Me.LabelABCD.Caption = Chr(i + 65) Lft = (i * 14) + Me.LabelABC.Left Select Case i: Case 10 To 12, 19 To 22: Lft = Lft - 2: End Select Me.LabelABCD.Left = Lft End Sub Dim Lft!, i% تعريف المتغيرات باختصار %=Integer !=Single x هو موقع الفارة من اليسار الى اليمين على العنصر وهي قيمة جاهزة من متغيرات الكود سؤال : الرقم 14 ؟ x / 14 اي هو الرقم 14 وليه نقسم الاكس في هذا الرقم منتظر الاجابة بحث بالاحرف.rar

السلام عليكم لقد لاحظت الان النطاقات المسماه اللي موجودة في الدالة تحتوي على 100000 صف هذا سبب الثقل !!!!! الاسم والشهر والمين او الدائن 300000 للمعادلة الوحدة

السلام عليكم اضغط الزر اللي امامك في المرفق Statement of Account (24.12.11) 2.rar

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

السلام عليكم اعمل فورم في اي ملف ونفذ الكود التالي Private Sub UserForm_KeyUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) MsgBox KeyCode End Sub بعد ما تفتح الفورم اضغط اي زر في الكيبورت وشوف رقمه =============================== ملاحظة : لاحظت الان في غلطه مطبعية في الرد السابق الكود الثاني هو TextBox1_KeyDown ساقوم بتصحيحه الان ودمتم

السلام عليكم هذا الكود للتجربة قم بتنفيذه من الشبت Detailed Trial Balance وعاين النتائج في النطاق "C4:AB20"

السلام عليكم ورحمة الله اخي الفاضل نفس الحاصل الذي اورده اخي بن عليه الملف ثقيل عند التنفيذ جرب الكود التالي على عشرين صف زي ما هو معمول اذا ناسبك زيادة النطاق الخاص بيك Option Explicit Sub kh_Evaluate() Dim X As Boolean Dim Rng As Range, Col As Range Set Rng = Sheets("Detailed Trial Balance").Range("C4:AB20") Rng.ClearContents Application.ScreenUpdating = False Application.Calculation = xlCalculationManual For Each Col In Rng X = Col.Column Mod 2 = 1 Select Case X Case True: Col = Application.Evaluate("=SUMPRODUCT((Name=" & Cells(Col.Row, 2).Address & ")*(Month=" & Cells(1, Col.Column).Address & ")*Madine)") Case False: Col = Application.Evaluate("=SUMPRODUCT((Name=" & Cells(Col.Row, 2).Address & ")*(Month=" & Cells(1, Col.Column).Address & ")*Daine)") End Select Next Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True Set Rng = Nothing End Sub ودمتم في حفظ الله

السلام عليكم اختار الكود الذي يناسبك الاول عند الضغط على الزر شفت مباشرة Private Sub TextBox1_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) If KeyCode = 16 Then UserForm2.Show End Sub هذا عند افلات الزر شفت Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) If KeyCode = 16 Then UserForm2.Show End Sub ودمتم في حفظ الله