حسين مامون

انسخ الكود والصقه مكان السابق طبعا بعد اضافة ال فورم 2 و 3 Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) 'Application.ScreenUpdating = False On Error Resume Next If Target.Column = 4 Then ' = 4 And Target.Row > 9 Then UserForm4.Show ElseIf Target.Column = 5 Then UserForm3.Show ElseIf Target.Column = 6 Then UserForm2.Show End If End Sub

ربما يكون المطلوب Option Explicit Sub tot() Dim lr, x, to1, to2 Dim Dt1, Dt2 to1 = 0 to2 = 0 Dt1 = [a2] Dt2 = [b2] lr = Cells(Rows.Count, 2).End(3).Row For x = 5 To lr If Cells(x, 3).Text = Range("c2") Then Select Case Cells(x, 2).Value2: Case Dt1 To Dt2 to1 = to1 + Cells(x, 4).Value to2 = to2 + Cells(x, 5).Value End Select End If Next x Range("d2").Value = to1 Range("e2").Value = to2 End Sub

اتمنى ان يكون ما تريد Try VBA 64 for First time.xlsm

عندي يعمل 100/100 ربما اسماء الشيتات هي سبب ذلك حاول نسخ اسم كل شيت والصقه مكان الاخر في الشيت

جرب المرقق الرقم السري 123 في جميع الازرار يمكنك تغييره في كل زر داخ الاكواد انظر الصورة Data-2021.xlsm

اخي الكريم اطلعت على ملفك وعندي ملاحظة 1 هناك تكرار في code الموجود بالعمود "C" واذا كان هذا شرط البحث فلا يجب ان يتكرر. 2 اشرت انك تريد ادخال البيانات في اي خلية فارغة ان تحقق الشرط ولكن في الفورم هناك 3 صندوق ادخال فقط و 18 عمود في صفحة العمل . اقترح عليك اعادة تصميم الفورم يعني 18 عمود = 18 صندوق ادخال للاستعلام عن جميع البيانات حسب code ومن تم يمكنك تعبئة اي خلية فارغة كما تريد واعادة ترحيلها الى الصفحة. هذا فقط اقتراح

اتمنى ان يكون الشرح مفيد

جرب المرفق تعديل فروم.xlsm

جرب المرفق جدول 2.xlsm

بعد ادن الاستاد خيماوي كووول ضع هذه في الخلية d22 =if($A$40="توريد فقط";"الشركة غير مسؤولة عن عيوب التركيب";"ضمان تركيب المكيف سنة واحدة من تاريخ الفاتورة") وضع هذه في الخلية d23 =if($A$40="توريد فقط";"";"في حالة لزوم كرسي جداري 60 ريال") وضع هذه في الخلية d24 =if($A$40="توريد فقط";"";" في حالة لزوم نحاس زيادة 70 ريال للمتر وفك المكيف القديم 100 ريال") وهذا الملف فاتورة (4).xlsm

حفظك الله وزادك الله من فضله استاذ مجدي يونس

ان كان ما تقصد هو نسخ الفاتورة ولصقها في اخر صف فارغ من نفس الورقة فاليك هذه التجربة المتواضعة ******تحياتي******* Sub copy_fact() Dim lr lr = Cells(Rows.Count, "g").End(3).Row + 5 Range("A1:H33").Copy Range("a" & lr) End Sub جدول.xlsm

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

جرب المرفق Items.xlsm

جرب الماكرو هكذا ربما يفي بالغرض Sub Macro1() Application.ScreenUpdating = False Dim Cont As Integer Dim lr Cont = Range("h1").Value lr = Range("b" & Rows.Count).End(xlUp).Row With Range("b4:h" & lr) .Sort .Columns(4), xlAscending .Sort .Columns(3), xlAscending .Sort .Columns(6), xlDescending End With With Range("h4:h" & lr) .FormulaR1C1 = "=MOD(ROW()-4," & Cont & ")+1" .Value = .Value End With With Range("b4:h" & lr) .Sort .Columns(7), xlAscending End With Application.ScreenUpdating = True End Sub

الف الف مبروك لهما ومسيرة موفقة باذن الله

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

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

ربما يكون حل

ربما يكون ما نقصد ترحيل مدين ودائن (1).xlsb

سكرا لك اخي ولك نصيب من الاجر ان شاء الله بالنسبة لسؤالك اولا لم تشر الى ذلك في مشاركتك الاولى بحيث اختصر طلبك (هكذا:كود الثانى- كود جلب البيانات لصفحة TAKRIR عن طريق اختيار التاريخ من والتاريخ الى فيتم استدعاء البيانات الموضحة بالشيت ) عموما ساحاول لما تسمح ظروفي رغم صعوبة الطلب وهذا ان لم يتفضل احد الاساتدة بالمساعدة تحياتي

تفضل فاتورة(2)(6).xlsm

ترحيل مدين ودائن (1).xlsb

جرب المرفق فاتورة(2).xlsm

جرب فاتورة(2).xlsm