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

أخي الكريم زوهير إليك الكود التالي عله يفي بالغرض Private Sub CommandButton2_Click() Dim iRow As Long Dim WS As Worksheet Dim Col As Long, Y As Long Set WS = Worksheets("Feuil1") Col = 1 iRow = WS.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Row If iRow > 5 Then iRow = WS.Cells(Rows.Count, "K").End(xlUp).Offset(1, 0).Row: Col = 11 WS.Cells(iRow, Col).Value = Me.TextBox1.Value WS.Cells(iRow, Col + 1).Value = Me.TextBox2.Value WS.Cells(iRow, Col + 2).Value = Me.TextBox3.Value WS.Cells(iRow, Col + 3).Value = Me.TextBox4.Value WS.Cells(iRow, Col + 4).Value = Me.TextBox5.Value WS.Cells(iRow, Col + 5).Value = Me.TextBox6.Value WS.Cells(iRow, Col + 6).Value = Me.TextBox7.Value WS.Cells(iRow, Col + 7).Value = Me.TextBox8.Value WS.Cells(iRow, Col + 8).Value = Me.TextBox9.Value WS.Cells(iRow, Col + 9).Value = Me.TextBox10.Value For Y = 1 To 10 Controls("TextBox" & Y) = "" Next Y Application.ScreenUpdating = True End Sub Private Sub CommandButton4_Click() Unload Me End Sub كل ما ستقوم بتغييره هو السطر التالي If iRow > 5 غير الرقم 5 إلى آخر صف تريد التعامل معه .. سحب طلبك الرقم يجب أن يكون 1000000 أرجو أن يكون هذا هو المطلوب

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

بارك الله فيك أخي الحبيب سليم القضية ليست في العمل على المطلوب .. أريد أن أعرف سبب المشكلة في الملف المرفق في المشاركة رقم 2

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

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

أخي الحبيب علاء رسلان بارك الله فيك وجزاك الله خيراً وأنت أهل لتصحيح أخطاء اللغة العربية .. وإذا لم تكن محترفاً فإني أراك كذلك أخي الغالي أبو يوسف جزيت خيراً على مرورك العطر بالموضوع ، وعلى دعائك الطيب المبارك الذي يزينه السجع الجميل تقبل الله منا ومنكم صالح الأعمال وجمعنا الله في مستقر رحمته يوم القيامة :fff:

أخي الكريم زوهير .. هل تقصد الترحيل مرتين للنطاقين أم ماذا تقصد بالضبط بالترحيل إلى أكثر من نطاق؟ مزيد من التوضيح

أخي الكريم أبو حبيبة جرب المعادلة التالية في الخلية B4 ="( " & B3*10% & " )" بالنسبة لطلبك الثاني يمكنك الإطلاع على المرفق التالي Tafket OB.rar

السلام عليكم ورحمة الله وبركاته إخواني وأحبابي في الله كل عام وأنتم بخير والأمة الإسلامية بخير ************** أقدم لكم موضوع خفيف .. الموضوع ببساطة كالتالي نفترض أن لديك بيانات في الصف الأول وتريد تقسيم البيانات بشكلٍ ما إلى عدة أعمدة ، وفي كل عمود عدد معين من البيانات بالمثال يتضح المقال في الصف الأول ضع أرقام من 1 إلى 40 في الأعمدة من A إلى AN (ركز في الصف الأول وليس في العمود الأول) في الخلية A3 سنقوم بوضع معادلة تؤدي مهمة التقسيم .. المعادلة بهذا الشكل =INDEX($1:$1,,1+MOD(ROWS($A$3:A3)-1,8)+8*(COLUMNS($A$3:A$3)-1)) كيفية استخدام المعادلة : المعادلة وضعت في الخلية A3 ومن ثم عندما تريد التعديل في المعادلة بما يتناسب مع ملفك قم بالتغيير في المعادلة في الأجزاء التالية ROWS($A$3:A3) COLUMNS($A$3:A$3) أي أن خلية البداية سيتم الإشارة إليها في المعادلة أما الجزء الأول خاص برقم الصف الذي يحوي البيانات المراد تقسيمها $1:$1 آخر جزئية في المعادلة هو الرقم 8 (لما الرقم 8 مكتوب مرتين في المعادلة) ... بما أننا نريد تقسيم الـ 40 بيان إلى أعمدة وفي كل عمود 8 بيانات على سبيل المثال إذاً سيتم التعامل مع ( 40 / 8 = 5 ) أي 5 أعمدة بعد وضع المعادلة في الخلية A3 يتم سحب المعادلة بمقدار 8 صفوف إلى أسفل و 5 أعمدة باتجاه السحب إليكم الملف المرفق فيه تطبيق للفكرة علها تفيدكم وتنال إعجابكم بالنسبة لشرح المعادلة أتركها للأخ الحبيب المتمكن خالد الرشيدي (بما لديه من ملكة - بفتح اللام يا أخ علاء رسلان وليس بكسرها - وموهبة فذة في شرح المعادلات) حمل الملف من هنا تقبل الله منا ومنكم صالح الأعمال

أخي الكريم جرب الكود بهذا الشكل Sub FilterData() Dim LR As Long, SH As Worksheet Application.ScreenUpdating = False For Each SH In ActiveWorkbook.Sheets If SH.Name <> "الرئيسية" Then With Sheets("الرئيسية") .Rows(3).AutoFilter .Rows(1).AutoFilter 8, "=" & SH.Name LR = .Range("A" & .Rows.Count).End(xlUp).Row If LR > 1 Then Union(.Range("B2:B" & LR), .Range("E2:E" & LR), .Range("H2:H" & LR)).Copy SH.Range("B" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlValues End If .Rows(1).AutoFilter End With End If Next SH Application.ScreenUpdating = True End Sub تم التعديل على الكود الأصلي ليقوم بعمل نسخ للقيم فقط بدون نسخ التنسيقات

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

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

أخي الفاضل أكرم جلال ننتظر منك الرد على المشاركة رقم 5 كما ننتظر منك تحديد أفضل إجابة طالما أن الموضوع قد انتهي وتمت الإجابة عليه تقبل تحياتي

أخي الكريم أيمن الحمد لله أن تم المطلوب على خير .. يمكن استخدام السطر التالي بدلاً من الكود بالمشاركة رقم 2 Sub TypeX() Range("A3:E32").Value = Evaluate("IF(I3:M32=1, ""X"", """")") End Sub أقترح عليك تبديل أفضل إجابة حيث أنه يجب أن تسعى دائماً للأفضل

أخي الكريم أيمن إبراهيم عوداً حميداً .. كل عام وأنت بخير جرب الكود التالي Sub TestRun() Range("A3:E1000").ClearContents With Range("A3:E32") .FormulaR1C1 = "=IF(RC[8]=1,R1C6,"""")" .Value = .Value End With End Sub تقبل تحياتي

أخي الكريم الملف المرفق في المشاركة الأولى غير معبر عن طلبك يرجى إرفاق ملف به ما تريد وما هو الزر المطلوب الضغط عليه وماذا تنتظر من الضغط على أن يتم تنفيذه غير ما طلبت؟ أعتقد مزيد من التوضيح كما تعودنا منكم أو جرب الملف التالي عله يكون المطلوب تقبل تحياتي Trim TextBox In UserForm.rar

الأخ الفاضل بكار لن أزيد في الكود شيء فقط عدل بداية الحلقة التكرارية ونهايتها بهذا الشكل For I = 12 To 30 Step 2 باقي أسطر الكود كما هي أرجو أن يفي بالغرض

إذاً كما ذكرت أ يتم التعامل مع التحديد بهذا الشكل في أكثر من سطر جرب الكود بهذا الشكل Sub trheel() Dim CL As Range, I As Integer For I = 2 To 4 For Each CL In Range("H2:H" & [H10000].End(xlUp).Row) If CL.Value = Sheets(I).Name Then CL.Offset(0, -6).Resize(1, 1).Copy Sheets(I).Range("B" & Sheets(I).[B10000].End(xlUp).Row + 1) CL.Offset(0, -3).Resize(1, 1).Copy Sheets(I).Range("E" & Sheets(I).[B10000].End(xlUp).Row) CL.Resize(1, 1).Copy Sheets(I).Range("H" & Sheets(I).[B10000].End(xlUp).Row) End If Next Next End Sub تقبل تحياتي

أخي الفاضل بكار للأبد صراحة لا أخفي عليك الملف بهذا الشكل غير مريح في العمل عليه عموماً .. إذا أردت نتائج صحيحة لابد من اتباع الآتي .. انسى أمر المعادلات في حالة التعامل مع الإيراد وإلا لابد من التحايل على الإكسيل وضبط الخيارات الخاصة بالإكسيل ليتعامل مع الخلايا المرجعية بشكل ما .. وأنا لا أحب تلك الطريقة ولذا أقدم لك كود يتم تنفيذه بعد الانتهاء من جميع الإدخالات .. ينفذ مرة واحدة لتحصل على الجزء المتبقي في خانة الإيرادات بالنسبة للمعادلة في الخلية AD10 يجب أن يسبقها الدالة Round لتصبح بهذا الشكل =ROUND(AC10-AC11,2) ثم قم باستخدام الكود التالي Sub Erad_YasserKhalil() Dim I As Long, X As Double For I = 11 To 29 Step 2 If IsEmpty(Range("AD" & I - 1)) Then GoTo 1 With Range("AB" & I) .ClearContents X = Application.WorksheetFunction.Round(Range("AD" & I - 1) - Application.WorksheetFunction.Floor(Range("AD" & I - 1), 0.05), 2) .Value = X End With 1 Next I End Sub أرجو أن يفي الكود بالغرض ..

أخي الكريم الغالي سعد عابد أعتذر عن التأخر في الرد على موضوعك إليك الكود التالي وإن شاء الله يفي بالغرض Sub PutSUMFormulas() Dim I As Long, II As Long II = 6 For I = 6 To 48 If IsEmpty(Cells(I, 2)) Then With Cells(I, 3).Resize(, 21) .Interior.Color = RGB(192, 192, 192) .Formula = "=SUM(R[-" & I - II & "]C:R[-1]C)" End With II = I + 1 End If Next I End Sub ولا تنسى أن تحدد أفضل إجابة ومش بس كدا أن تضغط على أعجبني هذا (إلا إذا لم يعجبك فلا تضغط عليها ) تقبل الله منا ومنكم وكل عام وأنتم بخير Put SUM Formulas By Code.rar

أخي الفاضل أبو إلياس بالنسبة لطلبك الثاني وهو تشغيل الماكرو عند فتح المصنف .. قم بإدراج الكود التالي بهذا الشكل في حدث المصنف Private Sub Workbook_Open() Call trheel End Sub بالنسبة لطلبك الأول الكود لا يقوم بتحديد الأعمدة من 1 إلى 7 بل من العمود الثاني بامتداد 7 أعمدة أي من 2 إلى 8 باستخدام خاصية Resize أعتقد أنه يجب عليك توضيح النتيجة المرجوة من التحديد لنعرف كيف نتعامل مع الكود .. يمكن تفريد سطر لكل عمود ونسخه على حدا (هذه طريقة) أو لربما نجد طريقة أفضل لو وضحت المطلوب بشكل جيد

الأخ الكريم محمود أهلاً بك في المنتدى ومرحباً بك يرجى تغيير اسم الظهور للغة العربية كما يرجى زيارة موضوع التوجيهات في الموضوعات المثبتة في المنتدى جرب المعادلة التالية علها تفي بالغرض بفرض أن الرقم في الخلية A1 =ROUND(A1-0.0001,2) تقبل تحياتي

أخي الكريم قم بزيارة الرابط التالي عله يفيدك في كيفية التعامل مع المنتدى من هنا

أخي الكريم حسين إليك الملف المرفق فيه تطبيق للدالة عله يفيدك .. وأي استفسار اسأل وإن شاء الله تجد المساعدة من إخوانك بالمنتدى Birth Date.rar

الأخ الفاضل محمد الموافي يرجى تحديد أفضل إجابة ليظهر الموضوع مجاب ومنتهي الالتزام بالتوجيهات مطلوب ... تقبل تحياتي