طارق محمود

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

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

السلام عليكم أخي الكريم شكرا لك لأنك جعلتني استمتع بمتابعة عمل من أعمال أستاذنا الجليل / عبد الله باقشير أرجو أن يكون الملف المرفق هو ماتريد لاحظ: لن يلغي الكود صفحة اللغة العربية حيث أنها بالصف 10 وأنت طلبت إلغاء الورقات التي اسمائها موجود في نطاق F11:F29 هذا هو الكود Sub T_Delete() Dim cel As Range Dim NamSheet As String Application.ScreenUpdating = False Application.DisplayAlerts = False For Each cel In Range("F11:F29") NamSheet = Trim(cel) If Len(NamSheet) = 0 Then GoTo 1 x = Sheets.Count For I = 1 To x If Sheets(I).Name = NamSheet Then Sheets(I).Delete: x = x - 1 If I = x Then GoTo 1 Next I 1 Next Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub وتفضل الملف به الكود ____برنامج محصلات و سجلات2.rar

أخي وحبيبي الأستاذ / رجب جاويش أخي وحبيبي الأستاذ / أحمد البحيري البقاء لله وحده (( وبشر الصابرين )) أسأل الله تعالى أن يتغمدها بواسع رحمته ومغفرته وان يدخلها جنته بدون حساب ولا سابقه عذاب وأن يلهمكما وجميع أهلها وذويها الصبر والسلوان ..

بعد إذن الجميع سأدمج الموضوعين لأنهما نفس الموضوع

السلام عليكم أخي عصام تفضل الملف المرفق به بعض البيانات الإفتراضية لعدد 4 مديرين فقط ومايلزمهم من مساعدين / مشرفين / عمال إن شاء الله يكون هو ماتريد لاحظ التالي 1- يوجد ورقة مخفية إسمها Sample يأخذ منها الكود التنسيق والفورمات للشيتات المطلوبة - يمكنك إظهارها وتعديلها ثم إخفاؤها قبل تشغيل الكود 2- أول سطر بالكود For i = 1 To 4 لأنني فرضت فقط أربعة مدراء ، يلزمك التعديل للعدد الذي تريد 3- لابد أن تكون أسماء شيتات البيانات كما فرضتها انا D1 , D2 , D3 , D4 4- السطر السادس بالكود به الأعداد الذي تريد التقسيم عليها بالترتيب ، يمكنك تعديله إن شئت x = Array(11, 29, 50, 495) 5- سينتج بواقي نتيجة أن الأعداد لن تقبل القسمة صراحة علي أرقام التقسيم لذك إما أن تزيدها جميعا بمقدار 1 مثلا ويكون آخر مدير معه عدد أقل منهم جميعا أو تعيد توزيع البواقي يدويا (لن يكون كبيرا) الكود كاملا Sub Tawzee3() For i = 1 To 4 Sheets("Sample").Visible = True Sheets("Sample").Copy after:=Sheets(Sheets.Count) [B2] = "المدير المسئول / " & Sheets("Manager's").Cells(i + 1, 2) ActiveSheet.Name = "T" & Format(i, "000") x = Array(11, 29, 50, 495) For sh = 1 To 4 nr = [B99999].End(xlUp).Row + 1 ' new Row ready for data st_R = x(sh - 1) * (i - 1) + 2 ' start Row fn_R = x(sh - 1) * i + 1 ' finish Row Sheets("D" & sh).Range("B" & st_R & ":J" & fn_R).Copy Cells(nr, 2) Next sh [A4] = 1: [A5] = 2: LR = [B99999].End(xlUp).Row [A4:A5].Select Selection.AutoFill Destination:=Range("A4:A" & LR) Next i Sheets("Sample").Visible = False End Sub تفضل الملف وبه البيانات الإفتراضية و الكود نموذج الداتا2.rar

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

السلام عليكم بعد إذن احبابي وإخواني الأفاضل : شوقي ربيع ، وحمادة عمر الكود كان مضبوط فقط الشرط الذي علي أساسه يخفي الخلية ويظهرها أن خلية العمود M شرطها أن تحتوي علي 0 وليس A تفضل أخي الملف وبه الكود بعد تعديل طفيف Sub TestSub Test_TAREQ() Dim i As Long For i = 1 To 4798 Step 40 If Range("M" & i) <> 0 Then GoTo 10 If Rows(i).EntireRow.Hidden = False Then Rows(i & ":" & i + 39).EntireRow.Hidden = True Else Rows(i & ":" & i + 39).EntireRow.Hidden = False End If 10 Next i End Sub كود اخفاء واظهار3.rar

السلام عليكم أخي أنس يمكنك إرسال الملفات علي إميلي tarekmahmoud_2@hotmail.com

السلام عليكم عندك حق أضف للكود هذا الجزء For r = LR To 6 Step -1 If Cells(r, 1) = tx Then Rows(r).Rows.Delete Shift:=xlUp Next r LR = [A9999].End(xlUp).Row وأيضا هذا السطر If st_rw > LR Then GoTo 10 قبل Next i ليصبح الكود النهائي Sub sub_tot() k = [I2]: tx = "المجموع" Application.ScreenUpdating = False LR = [A9999].End(xlUp).Row For r = LR To 6 Step -1 If Cells(r, 1) = tx Then Rows(r).Rows.Delete Shift:=xlUp Next r LR = [A9999].End(xlUp).Row rw_n = LR - 5 st_rw = 6 'start row for the sum sm_n = Int(rw_n / k) + 1 For i = 1 To sm_n X = k + st_rw ' X is end row for the sum If X > (LR + 1) Then X = LR + 1: k = X - st_rw LR = LR + 1 Rows(X).Rows.Insert Shift:=xlDown Cells(X, 1) = tx Cells(X, 2).FormulaR1C1 = "=SUM(R[-" & k & "]C:R[-1]C)" With Range(Cells(X, 1), Cells(X, 11)) .Interior.Color = 65535 .Font.Bold = True .Font.Size = 25 End With Range(Cells(X, 2), Cells(X, 11)).FillRight st_rw = st_rw + k + 1 If st_rw > LR Then GoTo 10 Next i 10 Application.ScreenUpdating = True End Sub

السلام عليكم أخي الكريم / سليم حاصبيا إستخدمت بعض مافي الكود الخاص بك وأضفت إليه اشياء (إسمح لي) إعتمدت أنه في كل مرة يحسب من جديد أول سطر سيبدأ منه المعادلة وآخر سطر وإذا كان آخر سطر أكبر من رقم السطر الأخير في البيانات فسيغير المعادلة قليلا واضفت أيضا (بدلا من تكرار المعادلة) خاصية FillRight التي تسمح بنسخ الخلية لليمين في المجال المحدد هذا هو الكود الجديد Sub sub_tot() k = [I2]: tx = "المجموع" Application.ScreenUpdating = False LR = [A9999].End(xlUp).Row rw_n = LR - 5 st_rw = 6 'start row for the sum sm_n = Int(rw_n / k) + 1 For i = 1 To sm_n X = k + st_rw ' X is end row for the sum If X > LR Then X = LR + 1: k = X - st_rw LR = LR + 1 Rows(X).Rows.Insert Shift:=xlDown Cells(X, 1) = tx Cells(X, 2).FormulaR1C1 = "=SUM(R[-" & k & "]C:R[-1]C)" With Range(Cells(X, 1), Cells(X, 11)) .Interior.Color = 65535 .Font.Bold = True .Font.Size = 25 End With Range(Cells(X, 2), Cells(X, 11)).FillRight st_rw = st_rw + k + 1 Next i Application.ScreenUpdating = True End Sub تفضل المرفق جرب وشوف جمع اختياري2.rar

السلام عليكم أخي / محمد رزق لا ياأخي لاتتأثر بالمعادلات أخي / سليم حاصبيا تسلم يداك الكود جيد جدا فقط ياأخي يحدث خطأ في الجمع الأخير إذا لم يكن عدد الصفوف يقبل القسمة علي الرقم الإختياري في الخلية (I2) جرب وشوف ، مثلا في الشيت <ورقة1 (2)> إذا إخترت رقم 7 في الخلية (I2) ستجد أن آخر مجموع قد جمع آخر 7 صفوف أي أنه كرر صفين من الجمع السابق وكذلك أضاف المجموع السابق للمجموع الحالي أي أنه بدلا من 500 + 540 + 600 + 230 + 240 = 2110 فإنه يعطي 230 + 240 + 2250 + 500 + 540 + 600 + 230 + 240 = 4830

السلام عليكم هذه الطريقة بلا كود قد تعجبك يمكن إضافة عمود قبل الجدول (وليكن باللون الأزرق) لحساب رقم الصفحة الذي يتغير كل 15 صف ثم من قائمة Data ثم Subtotal وبناءا علي هذا العمود الجديد يمكن عمل ذلك وستلاحظ الأرقام 1-2-3 في أعلي اليمين التي تكونت نتيجة ذلك إضغط علي كلا منها علي حدي لتتعرف عليها تفضل المرفق Book20.rar

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

السلام عليكم أخي الكريم بالجداول المحورية تستطيع تشكيل التقرير كما تحب ولكن يلزمك عمل تنشيط للجدول (ريفريش) كلما عدلت البيانات ، كليك يمين عالجدول ثم كما بالصورة الصفراء التي بالملف المرفق Office2.rar

السلام عليكم أخي الكريم إرسل الملف

السلام عليكم اين الملف

الحمد لله تشرفنا بك اخي الكريم في المنتدي نسيت أن أرحب بك كما هو المعتاد لأولي مشاركاتك أهلا ومرحبا بك بين إخوانك ونحمد الله أن جعلنا سبب لإيجاد ماتبحث عنه

السلام عليكم تفضل أخي الكريم الملف وبه شرح سريع للكود المستخدم رصيد الاجازات1.rar

السلام عليكم أخي عادل هذا غير صحيح لعلك لم تنتبه أن في آخر الكود فقرة مسؤولة عن إعادة ترتيب البيانات حسب التاريخ - إن كنت لاتريد ذلك إلغيها نتيجة لهذا تم ترتيب النتائج حسب التاريخ فأصبح البيان موجود بالسطر 1104 من شيت اجمالى العملاء >>> لاحظ أن في نهاية الجدول تبين أن بعض التواريخ تم ادخالها بطريقة خاطئة السطرين 1377 و 1378 لأنك لغيت الكود (والذي أخذ مني وقت) ، أقصد الكود اللي في المشاركة 7 بصراحة ليس عندي وقت آخر أعذرني لأن الكود يعمل أوتوماتيكيا في حدث تنشيط الورقة ، يعمل عند كل مرة تدخل فيها إلي الورقة يمكنك إيقافه وجعله يعمل بزر حسب الطلب وليس في كل مرة ندخل للشيت

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

السلام عليكم تفضل المرفق وهذا هو الكود بعد النعديل Sub tarek() LR = [B9999].End(xlUp).Row If LR < 4 Then LR = 4 Range("B" & LR & ":G4").ClearContents Range("I4:K" & LR).ClearContents With Sheets("خروج ثلاجة") LR = .[B9999].End(xlUp).Row .Range("B4:F" & LR).Copy [B4].PasteSpecial Paste:=xlPasteValues .Range("G4:H" & LR).Copy [I4].PasteSpecial Paste:=xlPasteValues .Range("Q4:Q" & LR).Copy [K4].PasteSpecial Paste:=xlPasteValues End With With Range([F9999].End(xlUp), [F4]) .Copy [G4] .ClearContents End With nnLR = [B9999].End(xlUp).Row + 1 With Sheets("دخول جبنة ثلاجة") LR = .[B9999].End(xlUp).Row .Range("B4:F" & LR).Copy Cells(nnLR, 2).PasteSpecial Paste:=xlPasteValues .Range("G4:G" & LR).Copy Cells(nnLR, "I").PasteSpecial Paste:=xlPasteValues .Range("L4:L" & LR).Copy Cells(nnLR, "K").PasteSpecial Paste:=xlPasteValues End With LR = [B9999].End(xlUp).Row Range("B3:K" & LR).Select Range("C3").Activate Selection.Sort Key1:=Range("C4"), Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1 [b2].Select End Sub اضافة عمودين.rar

السلام عليكم أخي الكريم كود جميل سلمت يداك ضبطت موضوع اللغة مع تضبيط خفييف Sub prim_between2() Dim m As Integer, n As Integer, y As Integer, x As Integer [a4:h100].ClearContents [a4:h100].ClearFormats m = Cells(1, 2) n = Cells(1, 4) If m > n Then Cells(1, 2) = n: Cells(1, 4) = m r = 4: c = 2 For x = m To n y = Int(x ^ 0.5) For i = 2 To y Do While x Mod i = 0 If x Mod i = 0 Then GoTo out Loop Next i Cells(r, c) = x With Cells(r, c).Font: .Bold = True: .Size = 20: End With With Cells(r, c).Borders(xlEdgeLeft) .LineStyle = xlDouble .Color = -16776961 .Weight = xlThick End With With Cells(r, c).Borders(xlEdgeTop) .LineStyle = xlDouble .Color = -16776961 .Weight = xlThick End With With Cells(r, c).Borders(xlEdgeBottom) .LineStyle = xlDouble .Color = -16776961 .Weight = xlThick End With With Cells(r, c).Borders(xlEdgeRight) .LineStyle = xlDouble .Color = -16776961 .Weight = xlThick End With With Cells(r, c) .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter End With c = c + 1 If c > 8 Then c = 2: r = r + 1 out: Next x Cells(1, 2).Select End Sub

أخي رجب عفوا لم أر مشاركتك

السلام عليكم تفضل المرفق بالمعدل حسب الجنس.rar