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

التعديل الدي يمكنني اظافته بعد معاينة الملف هو اختصار كود استدعاء الاحتياطي على النحو التالي Sub Compare() Dim lr As Long, i As Long, j As Long Dim strCol As String Dim WS As Worksheet: Set WS = Worksheets("Sheet1") Application.ScreenUpdating = False lr = WS.Columns("A:R").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row 'Columns C to R For i = 3 To 18 strCol = Split((WS.Columns(i).Address(, 0)), ":")(0) For j = 5 To lr If WorksheetFunction.CountIf(WS.Range(strCol & "5:" & strCol & lr), WS.Range("A" & j)) = 0 Then WS.Cells(Rows.Count, strCol).End(xlUp).Offset(1).Value = WS.Range("A" & j).Value End If Next j Next i Application.ScreenUpdating = True End Sub بالتوفيق...........

ربما لو قمت بارفاق عينة للنتائج المتوقعة اول مرة وبنفس تنسيق ملفك الاصلي لكنا في غنى عن كل هده المحاولات ووفرت علينا وعلى نفسك الكثير اختيارك لافضل اجابة عند توصلك للحل في اي مشاركة على المنتدى سوف تكون مرجعا لم يحتاجها من بعدك خاصة عند كثرت التعديلات فلا تغفل عنها 😉 الرجاء اخي @2saad أخذ هده الملاحظات بعين الاعتبار في المشاركات المقبلة. Option Explicit Sub test() Dim lr As Long, i As Long, j As Long Dim strCol As String Dim WS As Worksheet: Set WS = Worksheets("Sheet1") Application.ScreenUpdating = False lr = WS.Columns("A:R").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row 'الاعمدة من C الى F For i = 2 To 6 strCol = Split((WS.Columns(i).Address(, 0)), ":")(0) For j = 1 To lr If WorksheetFunction.CountIf(WS.Range(strCol & "1:" & strCol & lr), WS.Range("A" & j)) = 0 Then WS.Cells(Rows.Count, strCol).End(xlUp).Offset(1).Value = WS.Range("A" & j).Value End If Next j Next i Application.ScreenUpdating = True End Sub

هدية مشروع صيدلية متكامل كنت قد سويته لصديق ويعمل عنده للحين. طبعاً هناك آراء وتوجيهات . فقلبي وعقلي يتسع للجميع . واليكم المرفق https://www.mediafire.com/file/r06g7b7zwdqkq7q/Tariq+Farmacy.rar/file

إخواني أعضاء المنتدي الكرام بعد سلام الله عليكم ورحمة الله وبركاته هذا الملف مساهمة مني لهذا الصرح العظيم وللأعضاء الذين لهم أفضال كثيرة علي والذي ساعدني فيه ( الاستاذ محمد هشام وأخي ابراهيم صديقي )سعد.xlsm هذا الملف لرجال التعليم في توزيع الملاحظين علي اللجان بنظام الفترات أنا صممته للابتدائي اليوم والفترة وهي تعني ( المادة ) 4و5 تعني الصف الرابع والخامس 6 تعني الصف السادس يا ريت الخبراء يقيموه ولو فيه تعديل يكون أفضل من الخبراء

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

والله يااستاذ خليفة انت انسان جميل جدا جزاك الله خير على تقديم المساعدة لكل من له سؤال فى هذا المنتدى الرائع

Private Sub com1_Click() Call YMD(Me.Text1.Value) End Sub Function YMD(No As Integer) As Variant Dim Y As Long Dim M As Long Dim D As Long Y = Int(No / 365.25) M = Int((No - (Int(No / 365.25) * 365.25)) / 30.4375) D = No - ((Y * 365.25) + (M * 30.4375)) YMD = Y & " years " & M & " months " & D & " days" Me.DateD = D Me.DateM = M Me.DateY = Y End Function

مشاركة مع اخي وحبيبي الاستاذ خليفة على اعتبار الشهر 30 يوما Me.DateY = Me.Text1 \ 360 Me.DateM = (Me.Text1 Mod 360) \ 30 Me.DateD = Me.Text1 Mod 360 Mod 30 توزيع الايام الى تاريخ.rar

تفضل أخي @سلمان الشهراني . ووافني بالرد . توزيع الايام الى تاريخ-1.rar

الكود الخاص بك بعد التعديل Sub tarheel() Application.ScreenUpdating = False Dim ws As Worksheet, xx As Integer, ir As Integer xx = Sheet1.Cells(32, 3).End(xlUp).Row For Each ws In ThisWorkbook.Worksheets If ws.Name <> Sheet1.Name Then For r = 8 To xx If Cells(r, 3).Value = ws.Name And Cells(r, 3).Value <> Empty Then Range(Cells(r, 3), Cells(r, 5)).Copy lr = ws.Cells(Rows.Count, 1).End(xlUp).Row + 1 ws.Range("a" & lr).Value = Date ws.Range("b" & lr).PasteSpecial (xlPasteValues) End If Next End If Next Application.CutCopyMode = False Sheet1.Activate Sheet1.Range("b8:e21").ClearContents Application.ScreenUpdating = True End Sub بما انك تريد نسخ البيانات كقيم اليك حل اخر Sub test() Dim Sh As Worksheet Dim WS As Worksheet: Set WS = Worksheets("Sheet1") Dim iRow As Long, Rng As Range For Each Sh In ThisWorkbook.Worksheets If Sh.Name <> WS.Name Then Application.ScreenUpdating = False For iRow = 8 To 32 'WS.Range("C" & Rows.Count).End(xlUp).Row If WS.Cells(iRow, "C") Like Sh.CodeName Then Set Rng = WS.Range(WS.Cells(iRow, 3), WS.Cells(iRow, 5)) Sh.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Value = Date Sh.Cells(Rows.Count, "B").End(xlUp).Offset(1, 0).Resize(, 3).Value = Rng.Value 'WS.Range("B8:E21").ClearContents End If Next iRow End If Next Sh End Sub TEST SH.xlsm

ليس لي علم عن المعادلات التي تستخدمها لاكن لا اظن انها لديها اي علاقة بالموضوع قد تمت الاجابة عن طلبك وهو اخفاء الصفوف الصفرية اما مسالة المعادلة مجرد تخمين مني لا غير 😁 مع العلم انها تنفد المطلوب قد لاحظت انك لم تقم بوضع المعادلة بالشكل الصحيح جرب المرفق التالي ووافينا بالنتيجة قد تم الغاء امر الطباعة مؤقتا داخل الكود ووضع ActiveSheet.PrintPreview يمكنك تعديله بعد التجربة البرنامج v2.xlsm

لا بد تدخل على تنسيق خلية المدة وتجعلها نص. Calcul IEP_06.xlsm

السلام عليكم ورحمة الله تعالى وبركاته نظرا للطلب والتساؤلات الكثيرة حول الموضوع او نقاط فرعيه منه قاصدا من ذلك أن يكون الموضوع شاملا ومرجعا للراغبين فى ذلك والدراسبن اليكم بناء القاعدة والذى اتمنى على الله تعالى ان يبدأ البناء وينتهى بشكل احترافى بقدر الإمكان وسوف نبدأ من الصفر تباعا ان شاء الله سوف يتم تحديث الموضوع تباعا الموضوع بأمر الله سوف اضع له الخطوط العريضة طبقا للمؤسسة التى اعمل بها لاننى أصلا سوف اقوم بقاعدة البيانات لمؤسستى وبقدر الإمكان سوف أضع فى الحسبان ان يكون التصميم عام بقدر الإمكان ليتناسب ويتماشى مع الجميع ومع رغباتهم بقدر الإمكان اهلا بكل من يريد المشاركة فى ادراة الموضوع والافكار والتعديل او الاضافة و ...... مبدئيا خلونا نتفق وقتى ضيق فى الفترة المقبلة لما انا مقدم عليه فلذلك ارجو الاعتذار مقدما ان لم التفت الى اى تساؤلات والتى وإن حدث سوف يتم تأجيلها حتى ينتهى مشروع اعداد التطبيق لمؤسستى تماما ان شاء الله بسم الله وعلى بركة الله بداية المشروع اول شئ تصيد وتسجيل الاخطاء بجدول وده وظيفته تسجيل الحطأ باسم الحدث أو الدالة المستخدمة فى الكود عند تنفيذ امر ما ورقم الخطا وصفه للمساعدة مستقبلا فى الوقوف على اماكن الاخطاء لعمل الصيانة اللازمة طبعا تم التطرق اليه فى هذا الموضوع: ويمكنكم الذهاب اليه والمتابعة من هنا طيب حلو جدا جدا وعلشان انا هبدأ بالأكواد ملاحظات هامة جدا جدا جدا جدا لبداية صحيحة واحترافيه : كتابة كود احترافي تتطلب ممارسات جيدة واتباع مبادئ برمجية صحيحة. فيما يلي بعض النصائح التي يمكن أن تساعدك في كتابة كود احترافي: توضيح الكود: استخدم تعليقات لشرح الجزء العلوي من الكود وللأمور المعقدة. اختر أسماء مفيدة وواضحة للمتغيرات والدوال تدل على وظائفها التى تمت كتابتها من اجلها. التنظيم: استخدم الهندسة المعمارية لتنظيم البرنامج إلى وحدات صغيرة وقابلة لإعادة الاستخدام. قم بتقسيم البرنامج إلى وحدات ووظائف مستقلة. الأداء: ابتعد عن الأكواد المكررة وقدّم الأكواد القابلة لإعادة الاستخدام في وحدات. حافظ على الأداء بتجنب العمليات الزائدة غير الضرورية. اختبار الوحدات: قم بكتابة اختبارات للتأكد من أن وحدات الكود الخاصة بك تعمل كما هو متوقع. الأمان: تحقق دائمًا من صحة البيانات الواردة والخارجة من الدوال. تفادى استخدام الأكواد المعرضة لثغرات أمان. تحسين الأداء: استخدم الهندسة العكسية لتحسين الأداء. ابحث عن فرص لتحسين الكفاءة والسرعة. استخدام التعليمات البرمجية النظيفة: ابتعد عن استخدام المتغيرات العالمية عندما لا تكون ضرورية. تجنب الأكواد التي تعتمد على التبديلات الطويلة. توثيق الكود: وفر توثيقًا جيدًا للكود ليسهل على المطورين الآخرين أو نفسك فهم كيف يعمل البرنامج. متابعة المعايير: اتبع معايير البرمجة المتعارف عليها . التحسين المستمر: كن مستعدًا لتحسين الكود الخاص بك بناءً على التعلم وتغييرات متطلبات المشروع. الالتزام بتلك المبادئ يمكن أن يساعدك في كتابة كود أكثر احترافية وقابل للصيانة. حلو الكلام وكل ده هيبان بقدر المستطاع فى التعليمات البرمجية التى سوف تتم تباعا يمكنك استخدام البادئات التالية لتسمية العناصر والكائنات بشكل منظم ويجعل الشيفرة أكثر وضوحًا. البادئات تعتمد على النوع أو الدور الذي تقوم به العناصر: وعلى سبيل المثال وليس الحصر المتغيرات: int للأعداد الصحيحة. dbl للأعداد العشرية. str للنصوص. bool للقيم البولية اى True , False أو Yes , No . Dim intCounter As Integer Dim dblAmount As Double Dim strName As String Dim boolIsValid As Boolean المصفوفات: arr للمصفوفات. Dim arrNames() As String الدوال: Function للدوال التي تعيد قيمة. Sub للإجراءات (دوال بدون إرجاع قيمة). Function CalculateTotal() As Double Sub DisplayMessage() الكائنات: frm للنماذج (Forms). rpt للتقارير (Reports). tbl للجداول (Tables). qry للاستعلامات (Queries). cls للكائنات أو الفئات لتعريف الكلاسات (Classes). bas وحدات الشيفرة- الوحدات النمطية (Modules). tbl للجداول (Tables). qry للاستعلامات (Queries). Dim frmCustomer As Form Dim rptSales As Report Dim tblData As TableDef Dim qryFilteredData As QueryDef الثوابت: c للثوابت. Const cMaxValue As Integer = 100 المتغيرات العامة: g للمتغيرات العامة. Public gCounter As Integer المتغيرات المؤقتة: temp للمتغيرات المؤقتة. Dim tempValue As Integer التعليقات: REM لتعليقات الشيفرة. REM هذا تعليق لشرح الشيفرة الأشكال والعناصر الرسومية: btn للأزرار (Buttons). lbl للتسميات (Labels). txt لحقول النص (Textboxes). chk لمربعات الاختيار (Checkboxes). القوائم والمراقبين: cmb لقائمة الاختيار (Comboboxes). lst لقوائم الاختيار (Listboxes). cb لمراقبات الصندوق (Checkboxes). الكائنات الأخرى: app لكائن التطبيق (Application). cnn لكائن الاتصال (Connection). doc لكائن المستند (Document). الحقول والأعمدة: fld لحقول البيانات (Fields). col لعمود البيانات (Column).

اعتذر عن الانقطاع لظروف مرضية ان شاء الله سوف نبدأ فى الاستمرار تباعا بامر الله

أدخلت تعديل على الدالة ولكن هي تعمل بنفس الأسلوب التعديل أن تعطي القيمة "" في حالة عدم وجود وحدة القياس وتعطي الناتج بالسالب في حالة لم يجد نفس الوحدة. صاحب الموضوع يا أنه تاه أو أنه مل، إن شاء الله يرجع لنا سريعا. Function getBalance(DumpVal) As Variant Dim sht1 As Worksheet, main As Worksheet Dim lrow As Integer, row As Integer Dim unit As String Set sht1 = Sheets("ورقة1") Set main = Sheets("رئيسي ") getBalance = "" With sht1 lrow = .Range("B1").End(xlDown).row unit = Trim(.Cells(lrow, 3)) If unit = "" Then Exit Function getBalance = -.Cells(lrow, 2) End With With main lrow = .Range("B1").End(xlDown).row For row = lrow To 2 Step -1 If .Cells(row, 1) Like "*" & unit Then getBalance = .Cells(row, 2) + getBalance Exit For End If Next row End With Set sht1 = Nothing Set main = Nothing End Function getBalance_07.xlsm

على قد فهمي فأنا محسوب على منتدى الأكسس وكثير من أوامر ودوال الاكسل لا أستخدمها. Sub salim_rows() Dim t%, lr%, x%, z%, a% Dim my_rg As Range, k% Dim In_box, Col As Integer Application.ScreenUpdating = False If ActiveSheet.Name <> "m" Then GoTo End_Me del_Empty_rows In_box = Application.InputBox("How Many Rows", , 14) a = In_box - 1 'number of rows for every group z = 3 'number of rows to be insert every time x = 8 'first row to begine If a <= 0 Then Exit Sub t = x + a + 1 If z > 5 Then z = 5 '---------------------------------------- 'العمود الثاني Col = 2 'لإيجاد آخر سطر للعمود الثاني .. فهو يذهب لآخر الصفحة ثم يعود للخلف ليقف على آخر سطر 'lr = Cells(Rows.Count, 2).End(3).Row lr = Cells(Rows.Count, Col).End(xlUp).Row 'تقوم بإرجاع كائن نطاق يمثل كافة الخلايا الفاضية في العمود الثاني 'Set my_rg = Range("B" & x & ":B" & lr).SpecialCells(4) On Error Resume Next Set my_rg = Range(Cells(x, Col), Cells(lr, Col)).SpecialCells(xlCellTypeBlanks) '---------------------------------------- my_rg.EntireRow.Delete On Error GoTo 0 Do Until Cells(t, "B") = "" Rows(t).Resize(z).Insert Sheets("m").Range("My_DEB").Copy _ Cells(t, 1) t = t + a + z + 1 Loop End_Me: Application.ScreenUpdating = True End Sub

رسوم.xlsx تفضل اخي الكريم