عبدالله المجرب

اتقدم بالاصالة عن نفسي ونيابة عن جميع الاعضاء بالتهنئة الى الاخ الكريم Ahmed Elbhiry (أحمد البحيري) بمناسبة ترقيته الى عضو فعال وان شاء الله نرى فيه النشاط المعهود دائماً === سينقل الموضوع الى المنتدى الاجتماعي بعد فترة

السلام عليكم اخي يوسف كمرحلة أولى قمت بعمل كود لانشاء ورقة عمل بأسم المريض فستقوم بكتابة بيانات المريض كاملة ثم تضغط زر ADD فيتم انشاء ورقة باسم هذا المريض ولو تكرر اسم المريض فسيتم الانتقال الى ورقة العمل مباشرة جرب المرفق وان شاء الله نكمل المشوار حسب اقتراحاتك DR.yousif Elbanna.rar

السلام عليكم هذا الكود لاظهار الصفوف بعد إخفائها Sub Abu_Ahmed_Show() Rows("2:" & [E1000].End(xlUp).Row).EntireRow.Hidden = False End Sub

شاهد هذا الموضوع http://www.officena.net/ib/index.php?showtopic=31466

السلام عليكم اخي ابوجاد الله ضع هذا الكود في زر امر في Sheet4 Sub Abu_Ahmed() Range("B6:C33,E6:I29").ClearContents b = 2: c = 3: rr = 6 Dim cl As Range Set MySh = Sheets("sheet2") For Each cl In MySh.Range("M4:M" & MySh.[M10000].End(xlUp).Row) If cl.Value = [E4] Then Cells(rr, b) = cl.Offset(0, -11) Cells(rr, c) = cl.Offset(0, 8) rr = rr + 1 If rr = 34 Then b = 5: c = 9: rr = 6 End If Next End Sub

السلام عليكم ويمكن عدم استعمال زر ضع هذا الكود (هو نفس كود الاخ حجاب) في حدث This Workbook Private Sub Workbook_BeforeClose(Cancel As Boolean) Application.Quit ActiveWorkbook.Close SaveChanges:=False End Sub

السلام عليكم هل تقصد هكذا شيت1.rar

استاذ بن علية هذا هو ما كنت ساقوم به بالضبط سلمت يمينك

جرب هذه المعادلات لحذف حرفين =LEFT(A2,LEN(A2)-2) ولحذف اخر حرف =LEFT(A2,LEN(A2)-1)

ان شاء الله راح احاول اعمل الطلب وارجو ان تمهلني بعض الوقت

III = 6 'ـــــ ما ذا تشير اليه هذه تم تعيين القيمة 6 للرمز III وتعني الصف السادس =============== Do Until ورقة1.Cells(III, "J").Text = "" ' كيف اقوم بتغير عمود البحث ليصبح Dبدلا من ت ستصبح هكذا Cells(III, "D") =========== If Me.ComboBox1.Text = ورقة1.Cells(III, "B").Text Thenـ 'هل استطيع تغير كلمه ورقه1 لتصبح اسم معينATA تستطيع ان تستبدل ورقة 1 لتصبح كالتالي Sheets ("ATA").cells(III,"J") ============= III = III + 1 ' ما ذا يعنى ذلك طبعاً هذه حلقة تكرارية سيتم زيادة الصف بواحد حتى تحقق الشرط ================ ان شاء الله اكون وفقت في التوضيح ويقصد بهذا السطر ان الحلقة تستمر حتى الخلية التي في العمود J وتبداء من الصف السادس تكون بلا بيانات (خالية)

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

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

السلام عليكم جرب التعديل التالي Sub Abu_Ahmed() On Error Resume Next Application.ScreenUpdating = False Range("K7:N100").ClearContents w = 7 For Each cl In [B2:B23] If cl = [N3] And cl.Offset(0, 1) = [N4] Then MyArr = MyArr & Trim(cl.Offset(0, -1)) & "," End If Next If MyArr = Empty Then MsgBox "رقم القسم غير موجود لهذه المدرسة فرجاء تصحيح الخطأ ", vbOKOnly, "تنبيه": GoTo 1 For Each c In Split(Mid(MyArr, 1, Len(MyArr) - 1), ",") Cells(w, 11) = c Cells(w, 12) = [N3] Cells(w, 13) = [N4] Cells(w, 14) = Application.VLookup(c, [A2:D23], 4, 0) w = w + 1 Next LR = [K1000].End(xlUp).Row Range(Cells(6, "K"), Cells(LR, "N")).Sort Key1:=Cells(6, "N"), Order1:=xlDescending, Header:=xlGuess, _ OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal 1: Application.ScreenUpdating = True End Sub

السلام عليكم جرب هذه المعادلة لفصل اخر حرفين =MID(A1;LEN(A1)-1;2) لفصل اخر حرف =MID(A1;LEN(A1);2)

السلام عليكم جرب المرفق الاجازات.rar

شاهد هذا الرابط http://www.officena.net/ib/index.php?showtopic=31466

المطلوب غير واضح اين تريد الناتج

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

اين بالضبط في صفحة العملاء وهل العملاء اربعة فقط

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

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

السلام عليكم اليك هذا الرابط http://www.officena.net/ib/index.php?showtopic=39065

السلام عليكم استبدل الكود السابق بهذا Sub Abu_Ahmed() LR = [E1000].End(xlUp).Row For i = LR To 2 Step -1 If Cells(i, 5) = Empty Then Rows(i).EntireRow.Hidden = True End If Next End Sub

اخي هل جربت كود الاخ العيدروس على نفس مشاركة الملف السابق هذا هو Sub MKARNH_ALI() Application.ScreenUpdating = False Range("C2:D2,E2:F65536").ClearContents Q = [A15000].End(xlUp).Row For R = 2 To Q If Application.CountIf([B2:B5000], Cells(R, 1)) = 0 Then Cells([E15000].End(xlUp).Row + 1, 5) = Cells(R, 1) End If If Application.CountIf([A2:A5000], Cells(R, 2)) = 0 Then Cells([F15000].End(xlUp).Row + 1, 6) = Cells(R, 2) End If Next [C2].Value = [E15000].End(xlUp).Row - 1 [D2].Value = [F15000].End(xlUp).Row - 1 Application.ScreenUpdating = True MsgBox "الحمد لله", vbInformation, "تمت المقارنة" End Sub