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

:: السلام عليكم ورحمة الله وبركاته :: 🙂 يطيب لي أن أهديكم هذه الهدية البسيطة 🎁 :: مرسال الواتسأب :: وهو برنامج بسيط جدا لإرسال الرسائل عن طريق الواتسأب .. مع إمكانية إرسال المرفقات كذلك ( صور أو مستندات ) 🙂 وله واجهتين رئيسيتين : 1 - الرسائل الفردية 2 - الرسائل الموجهة لعدة أشخاص :: وهذه صور لواجهات البرنامج :: طبعا من الضروري تنصيب برنامج الواتسأب للكمبيوتر وتشغيله قبل تشغيل البرنامج 🙂 وبملاحظاتكم ودعواتكم دوما نرتقي 🙂 :: وأخيرا :: التحميل :: ☺️👌🏼 مرسال الواتسأب.accdb

الكود يعمل فقط على مربع النص الخاص بالتخصص انظر الصورة في الرد السابق لي ..... عموما تفضل ملفك بعد التعديل عليه ........ Database1601.accdb

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

السلام عليكم ورحمة الله تعالى وبركاته ..تفضل اخي الكريم Private Sub CommandButton1_Click() Dim filePath As String Dim Ws As Worksheet Application.ScreenUpdating = False filePath = Application.ActiveWorkbook.Path Set Ws = Sheets("بيانات") With Ws .Copy Application.DisplayAlerts = False Application.CutCopyMode = False Dim shape As Excel.shape For Each shape In ActiveSheet.Shapes shape.Delete Next Application.ActiveWorkbook.SaveAs Filename:=filePath & "\" & .Name & "" & "" & ".xlsx", FileFormat:=51 Application.ActiveWorkbook.Close False End With MsgBox "تم نسخ الملف بنجاح" Application.ScreenUpdating = True End Sub wor_MH.xlsm

السلام عليكم ورحمة الله اجعل المعادلة هكذا =MATCH(H2;INDIRECT(P2);0)

QR CODE.xlsm

طيب ادخل على تفصيل النموذج ..... حدث عند الطباعة وادرج الكود التالي .... Dim ctl As Control, strText As Variant, strName As String Me.ScaleMode = 1 For Each ctl In Me.Detail.Controls If ctl.ControlType = acTextBox And ctl.name = "Text4" Then strName = ctl.name If Nz(ctl.Tag, "") = "" Then ctl.Tag = ctl.FontSize End If ctl.FontSize = ctl.Tag Me.FontSize = ctl.FontSize strText = ctl.Value If Len(strText) > 0 Then Do Until TextWidth(strText) < ctl.Width ctl.FontSize = ctl.FontSize - 1 Me.FontSize = ctl.FontSize Loop Do Until TextHeight(strText) < ctl.Height - (ctl.Height * 0.26) ctl.FontSize = ctl.FontSize - 1 Me.FontSize = ctl.FontSize Loop End If End If Next ctl ثم انظر النتيجة ......................

tb10 قيمه الفاتورة AAAAA(1).xlsm

جرب جساب الفرق بين تاريخين.xlsx

وعليكم السلام ورحمة الله تعالى وبركاته ..تفضل اخي Sub ضياء_test1() LR = ActiveSheet.Cells(Rows.Count, "U").End(xlUp).Row '''''''''''''''''''''''''''' With Range("Z2:Z" & LR) .Formula = "=IF(U2=""رئيسي"",IF(X2>=200,X2*3.6*24,IF(X2<=40,X2*3.6*16,IF(X2<200,X2*3.6*20))),X2*3.6*24)" .Value = .Value End With With Range("AA2:AA" & LR) .Formula = "=IF(U2=""رئيسي"",IF(Y2>=200,Y2*3.6*24,IF(Y2<=40,Y2*3.6*16,IF(Y2<200,Y2*3.6*20))),Y2*3.6*24)" .Value = .Value End With End Sub او بهده الطريقة Sub ضياء_test2() LR = ActiveSheet.Cells(Rows.Count, "U").End(xlUp).Row '''''''''''''''''''''''''''' With Range("Z2:Z" & LR) .Formula = "=IF(RC[-5]=""رئيسي"",IF(RC[-2]>=200,RC[-2]*3.6*24,IF(RC[-2]<=40,RC[-2]*3.6*16,IF(RC[-2]<200,RC[-2]*3.6*20))),RC[-2]*3.6*24)" .Value = .Value End With With Range("AA2:AA" & LR) .Formula = "=IF(RC[-6]=""رئيسي"",IF(RC[-2]>=200,RC[-2]*3.6*24,IF(RC[-2]<=40,RC[-2]*3.6*16,IF(RC[-2]<200,RC[-2]*3.6*20))),RC[-2]*3.6*24)" .Value = .Value End With End Sub وبهده الطريقة بالنسبة لحدث الشيت Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Not Application.Intersect(Target, Range("x:y")) Is Nothing Then lr = ActiveSheet.Cells(Rows.Count, "u").End(xlUp).Row '''''''''''''''''''''''''''' With Range("Z2:Z" & lr) .Formula = "=IF(U2=""ورقة1"",IF(X2>=200,X2*3.6*24,IF(X2<=40,X2*3.6*16,IF(X2<200,X2*3.6*20))),X2*3.6*24)" .Value = .Value End With With Range("AA2:AA" & lr) .Formula = "=IF(U2=""ورقة1"",IF(Y2>=200,Y2*3.6*24,IF(Y2<=40,Y2*3.6*16,IF(Y2<200,Y2*3.6*20))),Y2*3.6*24)" .Value = .Value End With End If End Sub حساب.xlsm حساب _ حدث الشيت.xlsm

يسعدنى أن أكون اول من يقدم لك الشكر الجزيل اخى الكريم وجزاك الله خيرا يارب

السلام عليكم في الملف المرفق فيه طلبك ان شاء الله الملف الاصلي وهو من كنوز المنتدى فورم ادخال و تعديل مرن مع الطباعة 1.xls

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

السلام عليكم ورحمة الله تعالى وبركاته ..تفضل اخي Dim H, BT(), Rng, Ncol, MH1(), MH2(), MH3 Private Sub UserForm_Initialize() Set H = Sheets("BT") Set Rng = H.Range("A6:H" & H.[A65000].End(xlUp).Row) MH2 = Array(2, 3, 4, 5, 6) MH1 = Array(2, 3, 6, 4, 5) MH3 = 1 BT = Rng.Value Ncol = UBound(MH1) + 1 Me.ListBox1.ColumnWidths = temp & ";150" For i = Ncol + 1 To 5: Me("textbox" & i).Visible = False: Next i Set d = CreateObject("scripting.dictionary") d("*") = "" For i = LBound(BT) To UBound(BT) d(BT(i, MH3)) = "" Next i temp = d.keys Me.ComboBox1.List = temp Me.ComboBox1 = "*" End Sub ''''''''''''''''''''''''''''''''''''''''''''''''''''' Private Sub B_résultat_Click() Set MH = Sheets("التصفية") MH.Range("B10:F100").ClearContents A = Me.ListBox1.List MH.[b10].Resize(UBound(A) + 1, UBound(A, 2) + 1) = A With ThisWorkbook.Worksheets("التصفية") Sheet4.Range("c3") = ComboBox1.Text .Range("c5").Value = CDate(Me.TextBox2.Value) .Range("c7").Value = CDate(Me.TextBox3.Value) End With End Sub ''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Private Sub ComboBox1_Change() Sheet3.Range("P2") = ComboBox1.Text TextBox1.Value = Sheets("BT").Range("Q2").Value TextBox2.Value = Sheets("BT").Range("R2").Value TextBox3.Value = Sheets("BT").Range("S2").Value Dim Tbl(): ReDim Tbl(1 To Ncol + 1, 1 To UBound(BT)) ligne = 0 For i = 1 To UBound(BT) If BT(i, MH3) Like Me.ComboBox1 Then ligne = ligne + 1 c = 0 For Each k In MH1 c = c + 1: Tbl(c, ligne) = BT(i, k) Next k ' c = c + 1: Tbl(c, ligne) = i + Decal End If Next i ReDim Preserve Tbl(1 To Ncol + 1, 1 To ligne) Me.ListBox1.Column = Tbl End Sub ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Sub TriS(A, gauc, droi) ref = A((gauc + droi) \ 2) g = gauc: d = droi Do Do While A(g) < ref: g = g + 1: Loop Do While ref < A(d): d = d - 1: Loop If g <= d Then temp = A(g): A(g) = A(d): A(d) = temp g = g + 1: d = d - 1 End If Loop While g <= d If g < droi Then Call TriS(A, g, droi) If gauc < d Then Call TriS(A, gauc, d) End Sub Book_MH.xlsm

أبسط الحلول هي أن تكون الملفات كلها فى مجلد واحد و بالتالي لا تتأثر بنقل المجلد بالكامل و اذا كان هناك ملف به معادلات مرتبط بملفات أخري بها مصدر للبيانات فى مجلد معين و تغير مكان هذا المجلد يمكنك استبدال المسار باستخدام خاصية الاستبدال CTR+H مثلا اذا كان المجلد الذي به البيانات سابقا فى المسار C:\Users\mtara\Desktop\@risk\4\ ز كان اسم الملف على سبيل المثال b.xlsx و كانت احدى المعادلات فى الملف الذي به المعادلات على سبيل المثال C:\Users\mtara\Desktop\@risk\4\[b.xlsx]bb'!$A$1 و تم نقل الملف b.xlsx الذي يمثل مصدر البيانات الي المسار C:\Users\mtara\Desktop\1\ فتصبح المعادلة ='C:\Users\mtara\Desktop\1\[b.xlsx]bb'!$A$1 فيتم تنفيذ الاستبدال كالتالي مرة واحدة فى ورقة العمل بالملف الذي به المعادلات فتتحدث كل المعادلات لتقرأ من الملفات التي هي فى المسار الجديد : و تتغير كل الملفات

وعليكم السلام-نبهنا كثير جداً على هذا الأمر لا وجود لأى مشاركة بدون ملف !!!فلا تنتظر المساعدة من أحد بدون رفع ملف مدعوم بشرح كافى عن المطلوب مع وضع شكل النتائج المرجوة فلا يمكن العمل على التخمين وتجنباً لإهدار وقت كل من يطلع على مشاركتك دون أدنى جدوى أو أهمية مثلى أنا الأن !!!!!

السلام عليكم أخي الكريم قم بتفعيل ال Design Mode والذي هو في تبويب المطور لتتمكن من الكتابة في الورقة أو التعديل عليها وستحل هذه المشكلة بإذن الله.والسلام عليكم

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

السلام عليكم ورحمة الله تعالى وبركاته بالنسبة للكود يمكنك جعله بهده الطريقة اخي الكريم وسبب تاخيري عن الرد على طلبك هو انني كنت انتظر جوابك بخصوص كود المنتج لاكن للاسف جوابك غير مفهوم (كود المنتج يكتب آليا ) تتضمن عدة امور Private Sub CommandButton10_Click() If Me.txt_product.Value = "" Then MsgBox "الرجاء ادخال اسم المنتج", vbCritical Exit Sub End If If IsNumeric(Me.txt_price_pru) = False Then MsgBox "الرجاءادخال سعر شراءالمنتج", vbCritical Exit Sub End If If IsNumeric(Me.txt_price_sale) = False Then MsgBox "الرجاء ادخال سعر البيع", vbCritical Exit Sub End If Dim sh As Worksheet Set sh = ThisWorkbook.Sheets("product_master") If Application.WorksheetFunction.CountIf(sh.Range("b:b"), Me.txt_product.Value) > 0 Then MsgBox "هذا المنتج مضاف مسبقا", vbCritical Exit Sub End If With ActiveSheet If .FilterMode Then .ShowAllData lr = .Cells(Rows.Count, 1).End(3).Row + 1 Cells(lr, 1).Resize(, 4) = Array(lr - 1, txt_product, txt_price_sale, txt_price_pru) End With Me.txt_product.Value = "" Me.txt_price_sale.Value = "" Me.txt_price_pru.Value = "" MsgBox "Done", vbtnformation End Sub اما الزيادة التي سبق ان وعدتك بها في المشاركة السابقة هي عبارة عن ملفك يتضمن جميع الاظافات التي من الممكن ان تحتاجها . ترحيل _ تعديل _ حدف _ بحث بكود المنتج Private Sub CommandButton9_Click() '''''''''ترحيل البيانات''''''''' ''الشرط الاول'' If Me.txt_product.Value = "" Then MsgBox "الرجاء ادخال اسم المنتج", vbCritical Exit Sub End If ''الشرط الثاني'' If IsNumeric(Me.txt_price_pru) = False Then MsgBox "الرجاءادخال سعر شراءالمنتج", vbCritical Exit Sub End If ''الشرط الثالث'' If IsNumeric(Me.txt_price_sale) = False Then MsgBox "الرجاء ادخال سعر البيع", vbCritical Exit Sub End If ''التحقق من وجود اسم المنتج مسبقا '' Dim sh As Worksheet Set sh = ThisWorkbook.Sheets("product_master") If Application.WorksheetFunction.CountIf(sh.Range("B:B"), Me.txt_product.Value) > 0 Then MsgBox "هذا المنتج مضاف مسبقا", vbCritical Exit Sub End If ''''''''''' النطاق المرحل اليه'''''''''''' Dim lr As Long lr = Sheets("product_master").Range("B" & Rows.Count).End(xlUp).Row With sh .Cells(lr + 1, "b").Value = Me.txt_product.Value .Cells(lr + 1, "c").Value = Me.txt_price_pru.Value .Cells(lr + 1, "d").Value = Me.txt_price_sale.Value End With ''''''''افراغ textbox''''''' Me.txtSearch.Value = "" Me.txt_product.Value = "" Me.txt_price_pru.Value = "" Me.txt_price_sale.Value = "" ''''''''(A)ترقيم تلقائي لعمود '''''' ''مع امكانية حدف الصفوف '' Worksheets("product_master").Activate Application.EnableEvents = False With Range("a2:a" & Cells.Find("*", , , , xlByRows, xlPrevious).Row) .Formula = "=Row() - 1" .Value = .Value End With Application.EnableEvents = True MsgBox "تم الترحيل بنجاح", vbtnformation '' UserForm_تحديث '' Unload Me frm_product_master.Show End Sub '''''''''' البحث بكود المنتج'''''''''''' Private Sub CommandButton10_Click() Dim x As Long Dim y As Long x = Sheets("product_master").Range("A" & Rows.Count).End(xlUp).Row If Me.txtSearch.Value = "" Then MsgBox "الرجاء ادخال كودالمنتج", vbCritical Exit Sub End If For y = 2 To x If Sheets("product_master").Cells(y, 1).Value = txtSearch.Text Then txt_product = Sheets("product_master").Cells(y, 2).Value txt_price_pru = Sheets("product_master").Cells(y, 3).Value txt_price_sale = Sheets("product_master").Cells(y, 4).Value End If Next y End Sub ''''''''''''''''تعديل البيانات'''''''''''''''' Private Sub CommandButton12_Click() Dim x As Long Dim y As Long x = Sheets("product_master").Range("A" & Rows.Count).End(xlUp).Row If Me.txt_product.Value = "" Then MsgBox "الرجاء ادخال اسم المنتج", vbCritical Exit Sub End If If IsNumeric(Me.txt_price_pru) = False Then MsgBox "الرجاءادخال سعر شراءالمنتج", vbCritical Exit Sub End If For y = 2 To x If Sheets("product_master").Cells(y, 1).Value = txtSearch.Text Then Sheets("product_master").Cells(y, 2).Value = txt_product Sheets("product_master").Cells(y, 3).Value = txt_price_pru Sheets("product_master").Cells(y, 4).Value = txt_price_sale End If Next y Me.txtSearch.Value = "" Me.txt_product.Value = "" Me.txt_price_pru.Value = "" Me.txt_price_sale.Value = "" MsgBox "تم التعديل بنجاح", vbInformation End Sub ''''''''''''''''حدف صف معين'''''''''''''''' Private Sub CommandButton13_Click() Dim x As Long Dim y As Long x = Sheets("product_master").Range("A" & Rows.Count).End(xlUp).Row If Me.txtSearch.Value = "" Then MsgBox "الرجاء ادخال كودالمنتج", vbCritical Exit Sub End If For y = 2 To x If Sheets("product_master").Cells(y, 1).Value = txtSearch.Text Then Rows(y).Delete End If Next y Me.txtSearch.Value = "" Me.txt_product.Value = "" Me.txt_price_pru.Value = "" Me.txt_price_sale.Value = "" MsgBox "تم حدف البيانات بنجاح", vbInformation Call MH Unload Me frm_product_master.Show End Sub ''''''''''''''''UserForm _ تحديث واجهة '''''''''''''''' Sub Refresh_data() Dim sh As Worksheet Set sh = ThisWorkbook.Sheets("product_master") Dim lr As Long lr = Sheets("product_master").Range("a" & Rows.Count).End(xlUp).Row If lr = 1 Then lr = 2 With Me.ListBox .ColumnCount = 4 .ColumnHeads = True .RowSource = "product_master!A2:d" & lr End With End Sub Private Sub CommandButton14_Click() If MsgBox("هل تريد الخروج من البرنامج", vbQuestion + vbYesNo, "Confirmation") = vbYes Then Unload Me End If End Sub Private Sub ListBox_DblClick(ByVal Cancel As MSForms.ReturnBoolean) txtSearch.Text = ListBox.Column(0) If txtSearch.Text = Me.ListBox.Column(0) Then Me.txt_product = Me.ListBox.Column(1) Me.txt_price_pru = Me.ListBox.Column(2) Me.txt_price_sale = Me.ListBox.Column(3) End If End Sub المحل_MH.xlsm

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

السلام عليكم أخي الكريم ..باستخدام المصنف ذاته لأنه يحتوي على أكواد تتعلق بالـ QR CODE يمكنك وضع المعادلة التالية للحصول على النتيجة المطلوبة (( والله أعلم)). =URL_QRCode_SERIES("qr_code_1";CONCATENATE(B2;"-";C2;"-";D2;IF(E2<>"";"-";"");E2;IF(F2<>"";"-";"");F2;"-";B4;"-";B5);;"qrCode") يمكنك التعديل عليها بما يناسب طلبك QR CODE.xlsm

السلام عليكم ورحمة الله ..استخدم الكود التالى Private Sub CommandButton1_Click() Dim x As Double, y As Double, p x = Me.TextBox1.Value Select Case x Case 1000 To 4999 p = 0.3 Case 5000 To 6999 p = 0.2 Case 7000 To 9999 p = 0.1 Case Is >= 10000 p = 0.05 End Select y = x * p Me.TextBox2.Value = y End Sub

اخي خير اخترها افضل اجابة حتى نعرف انه تم الاجابة على السؤال .....

طيب اجعل الموشر في خانة البحث ثم اسحب الباركود بالماسح وانظر ....... Database1.accdb

تفضل التعديل تسجيل وقت الفتح - Copy.mdb

وعليكم السلام ورحمة الله تعالى وبركاته ..تفضل اخي تم اضافة كود الفاتورة للصفحات الاربعة AA.xlsm

وعليكم السلام-استخدم هذه المعادلة =IF($B7="مصطفي","لا يوجد","")

انا مثلك في البداية اتوقعت انا هناك عمليتين لكن لما تدخل جدول nas تجد ان هناك عمليه واحدة مكتمله تابعة للسجل برقم 4 وتاريخ 27 وتفصيلها في الجدول بواقع ثلاث سجلات 1500 وارد لمحمود 200 وارد لخالد باليورو و300 صدار لجابر اما في جدول ras فيوجد سجلين 4 وهو الاب للسجلات الثلاث التي تحدثنا عنها وسجل رقم 5 بتاريخ 24 وليس له سجلات تابعه وبخصوص التكرار الذي اشار اليه الاستاذ الفاضل عمر فهو بسبب اعتماده في عمل الاستعلام all على استعلامين اخرين ولم يتم اضافة حقلي الربط الموجود في الجدولين وهذا تسبب في وجود تكرار غير صحيح وقد تم تعديل مصدر الاستعلام في مشاركتي السابقة واضافة حقل الربط وبالتالي لن يظهر اي سجل غير مكتمل ولم يعد هناك تكرار تحياتي استاذ احمد

وهذا ما اريده جزاك الله خيرا على طيب دعائك ولك مثله وزياده وربنا يسعد ايامك وفيك بارك الله اخى والشكر لله ثم لاخواننا واساتذتنا جزاهم الله عنا كل خير اتفضل تعديل بسيط باستخدام الشرط داخل داله اللوب لانى لما عدلت كان الوقت متاخر فعدلت التعديل على السريع Sub Create_Record_For_Every_Item3() ' تكرار السجلات لقاعدة البيانات المقسمة Const RTableName As String = "ItemsCopy_Qr" ' الاستعلام الذي يتم الحاق منه السجلات Const ALLItemsTableName As String = "BarcodeItems_T" ' الجدول الذي الية يتم نسخ السجلات وتكرارها Dim stmailList As String Dim MyDB As Database Dim r As Recordset Dim SqlSt As String Dim ItemCounter As Integer Set MyDB = CurrentDb Set r = MyDB.OpenRecordset(RTableName) DoCmd.SetWarnings False SqlSt = " DELETE " & ALLItemsTableName & ".* FROM " & ALLItemsTableName & " ; " DoCmd.RunSQL (SqlSt) Do If r.Fields("InvoiceNum") = [Forms]![Run]![K1] And r.Fields("sisl") = True Then For ItemCounter = 1 To r.Fields("QuantityS") ' تكرار السجلات حسب الرقم الذي يوجد في الحقل QuantityS SqlSt = "INSERT INTO " & ALLItemsTableName & " (BarCodeNumber,PriceS,ItemName,curName,CuCodn,CodeCounter) VALUES ( """ & r.Fields("BarcodeReader") & """,""" & r.Fields("PriceS") & """,""" & r.Fields("ItemName") & """,""" & r.Fields("currNames") & """,""" & r.Fields("CuCode") & """," & ItemCounter & " );" DoCmd.RunSQL (SqlSt) Next ItemCounter End If r.MoveNext Loop Until r.EOF DoCmd.SetWarnings True If ItemCounter > 0 Then MsgBox "تم ترحيل السجلات بنجاح" Else MsgBox "لا يوجد سجلات لترحيلها" End If r.Close Set r = Nothing Set MyDB = Nothing End Sub مرفق الملف به ملفان واجه كل واحد بتعديل بالتوفيق mm.rar

السلام عليكم ورحمة الله وبركاته القلب يعتصر حزنا وانا اكتب لكم ... اغلاق منتدى شقيق ... منتديات الاكسس والوورد ....

السلام عليكم ورحمة الله ممكن مساعدة في استعلام يحدد غياب طالب اكثر من مره او مرتين او ثلاثه حسب الطلب واستعلام بين تاريخين ولكم شكري ‏‏الفياب.accdb

السلام عليكم أخي الكريم بالنسبة لحذف رد متعوب عليه و يمكن ان يفيد الاخرين ، فاتفق معك بان ذلك غير مناسب ، ولا اردي ما سبب حدوث ذلك، و باذن الله ساناقش الأمر مع الأحوة لتجنب حدوث ذلك مرة أخرى. و أعتذر على جدوث ذلك. بالنبسة للموضوع المغلق، تم فتحه الان لفترة اضافية، و السبب فى غلق المواضيع السابقة المكتملة هو تجنب رفعها عند الرد بالشكر مثلا بعد فترة طويلة مما يشتت متابعي الموضيع الجديدة بالقسم، سواء المتابعين بغرض القراءة او بعرض محاولة الرد. و السبب فى ذلك هو تكرار تعقيبات متتالية على مواضيع قديمة مغلق من قبل بعض الاخوة كانت تؤدي لرفع المواضيع القديمة بصورة قد تجعل الصفحة الاولي فى المنتدى كلها مواضيع من هذا النوع ، فتنتقل كافة المواضيع الجديدة للصفحة التالية و يصعب على المتابعين متابعة الجديد، حيث يتعين عليهم فتح كافة المواضيع الجديدة لمعرفة انها فقط قد تم رفعها بكلمة شكر. بينما يمكن استخدام الرموز التعبيرية للاعجاب او الشكر و التقييم دون اضافة رد و رفع الموضوع. و هذا الاجراء و غيره بالطبع قابل للتعديل وفق الظروف والمستجدات، و لكن هذا ما اجتمع الرأي عليه من فترة و لم يكن مطبقا من البداية، فقد وجد أنه الأفضل لعموم المستفيدين من الموقع باغلاق المواضيع المكتملة، و بالطبع لا يوجد رأي أو قرار ثابت ، بل يمكن تعديل أي شيء أو تعديله أو تضمين بعض الاستثناءات. مع ملاحظة أن غلق الموضوع لا يمنع التعقيب عليه وانما يمكن الاشارة له فى موضوع جديد لاستكمال الحوار و اذا لزم الامر و حينها يتم دمج الموضوعان. وهذه الحالة من حيث العدد هي الاقل مقارنة برفع المواضيع من خلال كلمات الشكر، و التي نفضل استبدالها بالعلامات التعبيرية كل لا يتم رفع المواضيع. و في حال وجود موضوع مميز يمكن الاقتراح على الاخوة المشرفين اضافته لقائمة المواضع المميزة المثبتة أو تثبيته لفترة كي تعم الفائدة بصورة اكبر ، و ايضا يمكن اضافته لمكتبة الموضع ليظهر ضمن عدد اقل من المواضيع المميزة ، فقسم الاكسيل بالمكتبة به اقل من 150 موضوع ، و اقترح عليك اضافة الموضوع المشار اليه الي مكتبة الموقع ليسهل الوصول اليه ، و عند الاضافة يتم فتح موضوع خاص بالحوار حول الموضوع بصورة آلية فى القسم المناظر و مواضيع الحوار حول ملفات المكتبة عادة لا يتم اغلافها حيث ترتبط بالملف المرفوع للمكتبة. و اقترح عمل مثال بسيط واضافته للمكتبة سواء بعمل مثال و ضمه لقسم الاكسيل بالمكتبة او رفعه ككود فى القسم المناظر. وفي حال اضافة مثال للمكتبة يمكن تعميمه على الاعضاء بالبريد ليصل للجميع . https://www.officena.net/ib/files/ و يسعدني استكمال الحوار معك اذا رايت هناك حاجة لذلك. و كما ذكرت لا توجد قواعد ثابتة ، و انما عندما نجد حاجة نناقش ما يلزم و نتفق على أي تعديل مطلوب للقواعد المتبعة.

بما انك لم تقم برفع ملف مدعوم بشرح كافى عن المطلوب مع وضع شكل النتائج المرجوة فعليك بإستخدام خاصية البحث بالمنتدى فبه كنوز ,,, فلا يمكن العمل على التخمين وتجنباً لإهدار وقت كل من يطلع على مشاركتك دون جدوى أو أهمية مثلى أنا الأن

لسيادتكم جزيل الشكر والتقدير لك بالغ التحية وزادك الله علما وخيرا

https://wayprograms.blogspot.com/p/contact-us.html

مجرد تخمين بناء على كلامك ..احدف هذه الاسطر في نهاية الكود Me.txt_product.Value = "" Me.txt_price_sale.Value = "" Me.txt_price_pru.Value = ""

يجب ان تكون متوفر عادة ولكن قم بازالة OLE automation ثم تحديده ثم اغلق الملف بعد حفظه وافتحه من جديد وابحث عن الاداة من داخل محرر الاكواد من قائمة refernce>tools >OLE automation وهذ ا موضوع مشابه كنت قد اجبت عليه احد الاعضاء يمكنك الاطلاع عليه واعلامي ماذا يحدث معك . https://www.officena.net/ib/topic/102575-كود-كليندر-يعمل-على-اوفيس-2003ولايعمل-على2013/#comment-618610 تحياتي .

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

بارك الله فيك استاذنا الكريم وزادك الله من فضله

بعد أذن الاستاذ/ إبراهيم الحداد ..مرفق ملف الأكسل بعد اضافة المعادلة. 11.xls

تفضل استاذنا ابو اشرف اوفسنا.accdb

اشكرك اخي الكريم @مبرمج متقاعد الله يجزيكم الخير

بارك الله فيك أ. أبو عاصم، مشاركة طيبة ونافعة دمتم بخير بارك الله فيك أ. أبو عاصم، مشاركة طيبة ونافعة دمتم بخير بارك الله فيك أ. أبو عاصم، مشاركة طيبة ونافعة دمتم بخير

وعليكم السلام ..قم أولاً بتحويل تنسيق الأرقام إلى رقم لأنها منسقة على شكل نص من V9:V15 أو اضرب قيمة كل خلية بـ 1 أما القيم الرقمية في العمود .AC9:AE15 استبدل كلمة دائن بفراغ وحوله إلى رقم ..أو استخدم المعادلة التالية: =SUBSTITUTE(AC9;"دائن";"") نموذج اوفيسنا.xlsx

تفضل بسيطة يمكنك التواصل مع الأستاذ خالد صابر .مصمم البرنامج المشروح بالفيديو وسينفذ لك طلبك ان شاء الله بمقابل مادى وللتواصل معه عبر الإميل :khaledsaber2030@gmail.com واتس : 00201007630611

جزاك الله خسر الثواب وأكرمك الله وأحسن الله اليك

Sub Test() Dim ws As Worksheet, sh As Worksheet, r As Range, d As Object, i As Long Application.ScreenUpdating = False Set ws = Sheets(1): Set sh = Sheets(2) Set d = CreateObject("Scripting.Dictionary") With ws Set r = .Range("B4:BF" & .Cells(Rows.Count, 3).End(xlUp).Row) For Each r In Intersect(r, r.Offset(1, 2)) If r.Value <> "" Then i = r.Row d(.Cells(i, 2) & .Cells(i, 3) & r) = Array(.Cells(i, 2), .Cells(i, 3), r) End If Next r End With With sh .Range("C3:BE15").ClearContents .Range("BK1").Resize(d.Count, 3) = Application.Transpose(Application.Transpose(d.Items)) .Range("BN1:BN" & d.Count).Formula = "=BL1&BM1" With .Range("C3:BE15") .Formula = "=IFERROR(INDEX($BK:$BK,MATCH($B3&C$2,$BN:$BN,0)),"""")" .Value = .Value End With .Columns("BK:BN").ClearContents End With Application.ScreenUpdating = True End Sub

بورك فيك تمت تجربة الملف يعمل 100 % الان لديا ملفان يعملان بنفس الطريقة ملف الاخ بن علية وملفك انت اخ سليم لكن بدوال مختلفة اكيد هو سحر الاكسيل يا خبراء ادامكم الله عونا لنا وزادكم من علمه

السلام عليكم ورحمة الله وبركاته أقدم لكم اليوم برنامج لتسجيل بيانات أجازات الموظفين -بارك الله فيكم ..الباسورد: 123 برنامج اجازات الموظفين.xlsm

لماذا تحتاج لتغيير هذه الأرقام مع دقة شاشة المستخدم هذه الأرقام تخص دقة الشاشة التي تم تصميم البرنامج عليها وتم ضبط حجم النموذج عليها بحيث إذا كانت دقة شاشة المستخدم مساوية لها لا يتغير شيء أما إذا كانت دقة شاشة المستخدم غير الدقة التي تم التصميم عليها يتم تغيير حجم النموذج وكل عناصره إلى ما يتناسب مع دقة شاشة المستخدم سواء بتكبير النموذج أو تصغيره