نجوم المشاركات

اتفضلى بعد التعديل طباعة باركود-1 (1).rar لان طلبها الاصلى ان تتحكم فى التقارير والعينات ولا تريد طباعة كل العينات للمريض (عافانا الله واياكم) ^_^

مشكورين حفظم الله وجدت المطلوب هنا

ابنتي العزيزة ..من الواضح انك تريدي تجميع التحاليل حسب التاريخ ال ID ثابت لك مريض (عافانا واياكم)

أستاذي الفاضل والأخ موسى ، كل العذر صدقاً لإني منذ أشهر تقريباً قد حملت الملف ونسيت فعلاً لمن هو هذا الملف وبانتظار جديدك وتميزك الذي تبهرنا به كعادتك 🥰

هناك تحديثات جذرية عملتها على هذه الملفات أخي @Foksh لعله يتسع لي الوقت لطرحها إن شاء الله 🙂

في مشاركة من أحد الأخوة ( وكل الشكر له مع العذر إن لم أتذكر اسمه ) في منتدانا على حد علمي ، كانت هناك فكرة عمل تحديث للبرنامج بطريقة جميلة علها تخدم فكرتك ؛ ارفقت الملف لأني على وشك الخروج من العمل ولم يسعفني الوقت في ادارة الأكواد حسب رغبتك للأسف . Update.zip

ابشر أخي @abood2626 بسويلك طلبك لكن بيأخذ وقت غالباً باكر يكون جاهز .

هل هذا ما تريد ؟ PC_info.rar

السلام عليكم نبدأ بها جرب الكود التالي Sub Test() Dim ws As Worksheet, sh As Worksheet, sTarget As String, lr As Long, m As Long, iRow As Long Application.ScreenUpdating = False Set ws = ThisWorkbook.Worksheets("اذن") lr = ws.Cells(Rows.Count, 1).End(xlUp).Row If lr < 6 Then MsgBox "No Data", vbExclamation: Exit Sub Select Case ws.Range("C2").Value Case "اذن صرف": sTarget = "صرف" Case "اذن اضافه": sTarget = "اضافه" Case Else: MsgBox "No Such Worksheet", vbExclamation: Exit Sub End Select Set sh = ThisWorkbook.Worksheets(sTarget) m = sh.Cells(Rows.Count, "B").End(xlUp).Row + 1 For iRow = 6 To lr sh.Range("A" & m).Resize(, 6).Value = Array(sh.Range("A" & m).Row - 2, ws.Range("E2").Value, ws.Range("C4").Value, ws.Range("C3").Value, ws.Cells(iRow, 1).Value, ws.Cells(iRow, 2).Value) sh.Range("I" & m).Value = ws.Cells(iRow, 4).Value If sh.Name = "اضافه" Then sh.Range("J" & m).Value = ws.Cells(iRow, 5).Value End If m = m + 1 Next iRow Application.ScreenUpdating = True MsgBox "Done", 64 End Sub

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

عملتها بالطريقه دى بس بصراحه بشكرك جدا يا استاذ عمر لمجهودك طباعة باركود-1 (1).rar فاضل بس الفلتر

DoCmd.Save Or DoCmd.RunCommand acCmdSaveRecord

مبروك حل المشكلة

السلام عليكم و رحمة الله اليك شرح الكود المطلوب ارجو ان اكون قد وفقت Sub LastTest() '-------------------- Dim i As Long, ws As Worksheet, Rng As Range Dim C As Range, p As Integer, x Dim Shp As Shape, Nam As String Set ws = Sheets("Sheet2") Application.ScreenUpdating = False Range("AO5:BB100") = "" ' مسح النطاق الذى سوف يتم ارسال بيانات التلاميذ الضعاف Set Shp = ws.Shapes(Application.Caller) ' تعريف الشكل حسب العنوان المكتوب عليه Nam = Shp.TextEffect.Text ' الاسم المكتوب على الشكل ws.Range("AQ1") = " الطلاب الضعاف اقل من 65 % ل" & Nam ' عبارة تكتب عقب الضغط على اى زر حسب الشهر p = 4 ' لعد التلاميذ الضعاف بدلا من الصفر يعنى i = 5 ' اول صف سوف يتم العمل عليه Do While i <= 70 ' آخر صف سوف يتم العمل عليه حسب المرفق و يم تغييره بسهولة With ws Select Case Nam ' الاعمدة التى سوف يتم العمل عليها حسب اسم الشهر المكتوب على الزر Case "شهر 10" x = Array(1, 2, 3, 4, 5, 6, 7, 11, 15, 19, 23, 27, 31, 35) Case "شهر 11" x = Array(1, 2, 3, 4, 5, 6, 8, 12, 16, 20, 24, 28, 32, 36) Case "شهر 12" x = Array(1, 2, 3, 4, 5, 6, 9, 13, 17, 21, 25, 29, 33, 37) Case Else End Select For j = LBound(x) To UBound(x) ' عدد الاعمدة المطلوبة للعمل عليها و تكون مصفوفة Set Rng = .Cells(i, x(j)) ' التعريف بالنطاق و جعل كل صف على حدة كمصوفة مستقلة بذاتها For Each C In Rng ' كل خلية فى هذا النطاق y = .Cells(4, x(j)) * 0.65 ' شرط النجاح If .Cells(i, x(j)) < y Then ' اذا كان الشرط غير متوافر m = m + 1 ' عد مواد الرسوب اقل من 65% If m > 1 Then GoTo 88: ' تكفى مادة واحدة ليبدأ للعمل عليها p = p + 1 ' العد For a = 0 To 13 ' عدد الخلايا التى سيتم ترحيل البيانات اليها .Cells(p, a + 41) = .Cells(i, x(a)) ' ترحيل البيانات .Cells(p, 41) = p - 4 ' مسلسل للتلاميذ الضعاف Next End If Next Next End With 88: m = 0 i = i + 1 Loop End Sub

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

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

نعم اخي يمكنك دالك بتعطيل هدا الصف فقط f.UsedRange = f.UsedRange.Value رغم انني عند كتابة الكود لاحظت ان الفكرة ربما لم كانت على يوزرفورم سوف تكون مميزة (لانني دائما عند الاشتغال على اي ملف اطمح الى تقديم الافضل رغم عدم طلبه ) لهدا قررت بعدما طلبت مني التعديل بانشاءه ربما يساعدك على الاشتغال على الملف بشكل افضل مع البقاء على الكود الاول ليبقى لك اختيار ما يناسبك طبعا اليك شرح الكود الاول ربما تحتاج يوما الا تعديل شيء ما Sub Créer_des_feuilles() Dim rng As Range, dico As Range, Cell As Range Dim arr(1 To 2) As String, f As Worksheet ' رسالة تنبيه عند كتابة اسم غير موجود على المصنف arr(1) = "المرجوا التحقق من إسم ورقة العمل" ' رسالة بنجاح النسخ تتظمن اسماء الاوراق الجديدة arr(2) = "تم نسخ اوراق العمل بنجاح" On Error GoTo Errorhandling NameWS = InputBox("أدخل إسم ورقة العمل المراد نسخها ", " نسخ ورقة العمل") ' التحقق من اسم ورقة العمل المراد نسخها If Evaluate("ISREF('" & NameWS & "'!A1)") Then Set rng = Application.InputBox(Prompt:=" حدد نطاق أسماء أوراق العمل: ", _ Title:="تسمية أوراق العمل", _ Default:=Selection.Address, Type:=8) For Each dico In rng ' تجاهل الفراغات اثناء التحديد If dico <> Empty Then Application.ScreenUpdating = False ' التحقق من وجود اسم الشيت مسبقا على المصنف If Not Evaluate("ISREF('" & dico & "'!A1)") Then Sheets(NameWS).Copy after:=ActiveWorkbook.Sheets(Worksheets.Count) Set f = ActiveSheet 'تسمية اوراق العمل f.Name = dico ' حدف الازرار f.DrawingObjects.Delete 'التحويل الى قيم ' f.UsedRange = f.UsedRange.Value ' تخزين اسماء الشيتات الجديدة For Each Cell In dico ws = ws & vbCrLf & Cell.Value Next Cell End If End If Next dico Application.ScreenUpdating = True MsgBox arr(2) & vbCrLf & ws, vbOKOnly, "تعليمات:" Else MsgBox arr(1), vbCritical, "إنتباه:" End If Errorhandling: End Sub تفضل اخي في انتظارك بعد تجربة الملف وسوف نكون سعداء دائما بمساعدتك Create-Sheets_User.xlsb

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