الـعيدروس

السلام عليكم استاذ عبدالله عمل موفق اسأل الله ان يجعله في موازين حسناتك

اخي قنديل الصياد كود رائع رائع بارك الله فيك وفي جهودك الطيبه تحياتي لك

تفضل اخذ رقم التقرير من "M4" وفورم البحث ان وجد وقت سوف اعمل عليه Public Sub Tr() Dim r, ri, rr, Inb$ Dim Chk, Nm, Ck, ii% Inb = InputBox("إدخل شرط الترحيل", , "rep") If Inb = vbNullString Or Inb = Cancel Then Exit Sub With Feuil5 On Error Resume Next Nm = [M4] r = 11: ri = 30 For rr = r To ri If .Cells(rr, 8) = Inb Then ii = ii + 1 With Feuil6.Cells(Rows.Count, 2).End(xlUp) For ic = 2 To 19 .Offset(1, ic - 2) = Feuil5.Cells(rr, ic) .Offset(1, 18).Value = Nm Next End With End If Next rr On Error GoTo 0 If ii Then MsgBox "تم الترحيل بنجاح", vbInformation, "" End With End Sub

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

السلام عليكم المرفق الاول شرح المرفق الاخر الملف وبه الكود تحياتي شرح.rar mnn_A.rar

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

السلام عليكم شاهد المرفق بتلاحظ اعدت نسخ الكود من الموضوع وذلك لان اللغة كانت انجليزي فظهرت الكتابه العربيه بالكود كعلامة ؟؟؟؟ فقمت بتحويل اللغة الى عربي "Alt + Shift" واعدت نسخ الكود كي تظهر اللغة العربيه في الكود كالطبيعه Wd.rar

السلام عليكم دالة Replace كيف لاتعمل مع الفيجول وهيا احد دوال الفيجول بيسيك اكيد انك لم تستخدمها بالشكل الصحيح

السلام عليكم احسنت صنعاً اخي زمزم

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

السلام عليكم أولاً عدل إسم الصف في القائمة في ورقة "cc" حسب ماهو في عمود "B" ورقة "aaa" عشان تجرب الكود بشكل السليم لا اعلم كم هيا درجة الرسوب ولاكن حط معطياتك في السطر التالي من الكود على اساس ماهو اصغر من القيمة يعتبر راسب '*********** ' درجة الرسوب Drg = 10 '*********** وهذا الكود Dim Ar() As Variant Public Sub Prn_a() Dim Lnc Dim Mh, Sn, Drg With ورقة1 '*********** ' درجة الرسوب Drg = 10 '*********** Mh = [IV4] Sn = [IV7] On Error Resume Next Lnc = Application.Match(Mh, .[F1:O1], 0) Cl = Lnc + 5 Lr = .Cells(.Rows.Count, 5).End(xlUp).Row For r = 2 To Lr If .Cells(r, 2) = Sn Then If .Cells(r, Cl) < Drg Then Rr = Rr + 1 ReDim Preserve Ar(1 To Rr) Ar(Rr) = .Cells(r, 2).Row End If End If Next On Error GoTo 0 If Rr Then Prn End With End Sub Private Function Prn() For ii = LBound(Ar) To UBound(Ar) With ورقة1.Range("B" & Ar(ii)) [D8] = .Offset(0, 0) [D7] = .Offset(0, 3) [F8] = .Offset(0, 1) ActiveSheet.PageSetup.PrintArea = [Print_Area].Address ActiveSheet.PrintPreview End With Next Erase Ar End Function حسب فهمي للطلب تريد جلب الاسماء التي توافي الشروط للطباعه تحياتي

السلام عليكم اضافة على الكود تحديد عدد المواضيع اختياري من قبل المستخدم Public Sub Ali_Copy_Sht() Dim Rng As Range Dim Mu_a$, Pth$ Dim ii%, i%, Nx%, Np% Dim Num%, A%, B%, x% '**************** On_1: Mu_a = "الموضوع" '**************** Np = 0 On Error Resume Next Num = ActiveDocument.ActiveWindow.ActivePane.Pages.Count A = InputBox("إدخل عدد الصفحات لكل موضوع", , 2) B = InputBox("إدخل عدد المواضيع", , 5) If (B * A) <> Num Then MsgBox "تأكد من عدد الأوراق لكل موضوع ", vbInformation, "": GoTo On_1 x = A - 1 For ii = 1 To Num Step A Np = Np + 1 i = ii: Nx = ii + x Selection.GoTo What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=i Set Rng = Selection.Range Selection.GoTo What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=Nx Rng.End = Selection.Bookmarks("\Page").Range.End Rng.Select Selection.Copy Application.Documents.Add Selection.Paste Pth = ThisDocument.Path & "\" ActiveDocument.SaveAs Pth & Mu_a & " - " & Np & ".docx" ActiveDocument.Close Next On Error GoTo 0 ActiveDocument.Range(1, 1).Select MsgBox "تم تقسيم كل موضوع في ملف بنجاح", vbInformation, "" Set Rng = Nothing End Sub

السلام عليكم جرب هذا الكود انشاء مودويل في ملف الوورد الذي به المواضيع والصق فيه الكود Public Sub Ali_Copy_Sht() Dim Rng As Range Dim Mu_a$, Pth$ Dim ii%, i%, Nx%, Np% '**************** Mu_a = "الموضوع" '**************** Np = 0 On Error Resume Next For ii = 1 To 10 Step 2 Np = Np + 1 i = ii: Nx = ii + 1 Selection.GoTo What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=i Set Rng = Selection.Range Selection.GoTo What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=Nx Rng.End = Selection.Bookmarks("\Page").Range.End Rng.Select Selection.Copy Application.Documents.Add Selection.Paste Pth = ThisDocument.Path & "\" ActiveDocument.SaveAs Pth & Mu_a & " - " & Np & ".docx" ActiveDocument.Close Next On Error GoTo 0 ActiveDocument.Range(1, 1).Select MsgBox "تم تقسيم كل موضوع في ملف بنجاح", vbInformation, "" Set Rng = Nothing End Sub الكود سيقوم بانشاء ملف لكل موضوع وحفظه في نفس فولدر الملف تحياتي

السلام عليكم فرضا الخلية المعينه هيا "A1" انشاء مودويل جديد والصق الكود التالي فيه وقوم بإدراج زر جديد واربطه بالكود Sub Set_Sh() Nm = [A1]: Sheets(Nm).Activate End Sub تحياتي

السلام عليكم الاخ ابو سعودد ارى انك سويت متاهات الطلب بإختصار بحث عن رقم في مدى معين وخلاص وجواب الشرط تريدها بإختصار ( موجود - غير موجود - قيمة البحث تجاوزت الحد الاعلى للقيم الموجودة ) ام هناك استخلاص اخر تريده ؟

السلام عليكم وهذه طريقة الى حلول الاستاذ حماده عمر بحث_تلقائي_Ali.rar

السلام عليكم جرب المرفق وتأكد من النتائج تحياتي Profseer_v3.3.rar

الفلسفه والمطوورين

السلام عليكم كود الترحيل Public Sub Tr() Dim r, ri, rr, Inb$ Dim Chk, Nm, Ck, ii% Inb = InputBox("إدخل شرط الترحيل", , "rep") If Inb = vbNullString Or Inb = Cancel Then Exit Sub With Feuil5 On Error Resume Next Ck = Feuil6.Cells(Rows.Count, 2).End(xlUp).Offset(0, 18) Chk = IsNumeric(Ck) Nm = IIf(Chk, Val(Ck) + 1, 1) On Error GoTo 0 r = 11: ri = 30 For rr = r To ri If .Cells(rr, 8) = Inb Then ii = ii + 1 With Feuil6.Cells(Rows.Count, 2).End(xlUp) For ic = 2 To 19 .Offset(1, ic - 2) = Feuil5.Cells(rr, ic) .Offset(1, 18).Value = Nm Next End With End If Next rr If ii Then MsgBox "تم الترحيل بنجاح", vbInformation, "" End With End Sub

لاشيء غير ممكن بالاكسل ولاكن العلم مراتب وانا لي محاولة لطلبك الاخير ان شاء الله تحياتي

اذا عرف الطلب بطل العجب اجل جرب المرفق اذا تكرمت وتقيم سرعة الكود عليك ارجو التجربه لانأمن مكر الاكواد Code Split3.rar

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

ارفق مثال وان شاء الله خير تحياتي

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

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