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

استخدم هذا الكود في حدث الحالي Private Sub Form_Current() If Not IsNull(Me.EmployeeID) Then Me.EmployeeID.Locked = True Me.EmployeeID.Enabled = False Me.EmployeeID.BackColor = vbYellow Me.EmployeeID.ForeColor = vbRed Else Me.EmployeeID.Locked = False Me.EmployeeID.Enabled = True Me.EmployeeID.BackColor = vbWhite End If End Sub

Sub Test() Dim rng As Range, c As Long Application.ScreenUpdating = False Set rng = Range("A5:J" & Cells(Rows.Count, "D").End(xlUp).Row) rng.UnMerge For c = 1 To rng.Columns.Count With rng.Columns(c) On Error Resume Next .SpecialCells(xlBlanks).FormulaR1C1 = "=R[-1]C" If c = 3 Then .Text = .Text Else .Value = .Value On Error GoTo 0 End With Next c Application.ScreenUpdating = True End Sub

وعليكم السلام..جرب هذا الكود Private Sub cmdBotton_Click() Dim HighestNumber As Long If (Me.نوع_الفاتورة) = "بيع" Then HighestNumber = Nz(DMax("[رقم الفاتورة]", "رأس الفاتورة")) + 1 Me.رقم_الفاتورة = HighestNumber End If End Sub

تفضل هذا التعديل اضافة هذه الشفرة في اي مكان داخل محرر الأكواد Public Sub EditSelse(Parcod As String) Dim db As DAO.Database, rs As DAO.Recordset, TbName As String TbName = "المنتجات" Set rs = CurrentDb.OpenRecordset("SELECT * FROM [" & TbName & "] where Barcode Like '" & Parcod & "'") If Not rs.BOF And Not rs.EOF Then rs.MoveFirst While (Not rs.EOF) Dim SubSeles As Double: SubSeles = Nz(DSum("number", "مبيعات", "ProductN Like '" & rs.Fields("productN").Value & "'"), 0) rs.Edit rs.Fields("Quantity").Value = rs.Fields("Quantity").Value - SubSeles rs.Update rs.MoveNext Wend End If rs.Close Set rs = Nothing End Sub و في ازرار اضافة الصنف اضف التالي Call EditSelse([srchb]) سيتم خصم كمية البيع مباشرة من المخزون مرفق الملف بعد التعديل تحديث الكميات بعد الدفع.zip

السلام عليكم تفضل أخي الكريم Private Sub CommandButton1_Click() For i = 1 To 3 Sum = Sum + Val(Me("Textbox" & i)) Next i Me.TextBox4.Value = Sum & ".00" ActiveCell = TextBox4.Value End Sub Private Sub CommandButton2_Click() For i = 1 To 3 Me("textbox" & i) = "" Next i End Sub Private Sub TextBox1_Change() For i = 1 To 3 Sum = Sum + Val(Me("Textbox" & i)) Next i Me.TextBox4.Value = Sum & ".00" End Sub Private Sub TextBox2_Change() For i = 1 To 3 Sum = Sum + Val(Me("Textbox" & i)) Next i Me.TextBox4.Value = Sum & ".00" End Sub Private Sub TextBox3_Change() For i = 1 To 3 Sum = Sum + Val(Me("Textbox" & i)) Next i Me.TextBox4.Value = Sum & ".00" End Sub active cell.xlsm

من خلال زرار open الموجود في النموذج Task List يقوم بفتح النموذج Task Detail ومن زرار Report سيفتح لك التقرير بالتاسك الذي اخترته ولم اقم بالتغيير في الكومبوبوكس ارجو ان يكون هذا مطلبك Database2Q.rar

Without any code, you can do it in few steps Filter the column by the word TOTAL then select the rows and delete. That's all

You can do that by sorting the listbox itself As for the second note, use the variable k to start equal to 1 then increment by one

It seems you didn't try my code well. Have a look at this line of code If c = 3 Then .Text = .Text Else .Value = .Value

تفضل مساعدات مرضية جديد.accdb

السلام عليكم ورحمة الله وبركاته .. تحية طيبة إخواني .. 🌹 أحضرت لكم اليوم كود وظيفته استخراج الملفات المخزنة في جداول الأكسس كمرفقات داخلية إلى خارج قاعدة البيانات دفعة واحدة 🙂 وهو مفيد جدا لمن لديه قاعدة بيانات قد ملئها بالمرفقات ويحاول الآن تصغير القاعدة باستخراج المرفقات منها وحفظها خارج قاعدة البيانات بسهولة ويسر .. بدل حفظها ملف ملف وهي عملية مرهقة بالتأكيد .. خصوصا إذا كان عدد المرفقات بالمئات .. إليكم الكود : Public Function ExtractAllAttachments(ByVal TableName As String, ByVal AttchmentColumnName As String, ByVal ExtractToFolder As String) ' TableName : اسم الجدول ' AttchmentColumnName : اسم حقل المرفقات ' ExtractToFolder: المكان المراد استخراج الملفات إليه مثال : "C:\ExtractHere" Dim RsMainrecords As dao.Recordset2 Dim RsAttachments As dao.Recordset2 Set RsMainrecords = CurrentDb.OpenRecordset("select " & AttchmentColumnName & _ " from " & TableName & _ " where " & AttchmentColumnName & ".FileName is not Null") Do Until RsMainrecords.EOF Set RsAttachments = RsMainrecords.Fields(AttchmentColumnName).Value Do Until RsAttachments.EOF Dim OutputFileName As String OutputFileName = RsAttachments.Fields("FileName").Value OutputFileName = ExtractToFolder & "\" & OutputFileName RsAttachments.Fields("FileData").SaveToFile OutputFileName RsAttachments.MoveNext Loop RsAttachments.Close RsMainrecords.MoveNext Loop RsMainrecords.Close Set RsMainrecords = Nothing Set RsAttachments = Nothing End Function ويتم تشغيله بالطريقة التالية : ExtractAllAttachments("TableName","AttchmentColumnName","ExtractToFolder") ستحتاج لإعطائه 1- اسم الجدول ، 2 - اسم الحقل ، 3 - المكان الذي تريد استخراج المرفقات فيه . المصدر : https://www.youtube.com/watch?v=jHIgay9goWo

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

تفضل اخي @nabilalibibo Database27.accdb

Option Explicit Private Sub CommandButton1_Click() Dim ws As Worksheet, i As Long, k As Long For i = 0 To Me.ListBox1.ListCount - 1 If Me.ListBox1.Selected(i) Then k = k + 1 Set ws = Worksheets(Me.ListBox1.List(i, 0)) ws.Move Before:=ThisWorkbook.Worksheets(k) End If Next i End Sub Private Sub UserForm_Activate() Dim ws As Worksheet With Me.ListBox1 .Clear For Each ws In Worksheets .AddItem ws.Name Next ws End With End Sub

ما شاء الله تبارك الرحمن نفع الله بكم أساتذتنا الكرام إي بالله صدقت نفخر بوجود أمثالكم، وتقبل الله منكم. عفوًا أيها الكرام هل ممكن حل لمسألة الشعبة مثلا 10\7 مع فك الدمج يعطيني تاريخ!!

أخي awael5 هذه القائمة تظهر عندما تكون لديك حقول مرتبطة بجدول أو استعلام .. تفضل هذه الطريقة .. عند النقر المزدوج على رأس العمود تظهر لك القائمة .. القوائم جاهزة.accdb

اخى هل ستفوم بتكرار تنفيذ الكود عشر مرات لعشرة اعمدة ناهيك عن ان الكود طويل خليك في المصرى افضل من الاجنبي صناعة مصرية خالصة لوجه الله الكود لعسرة اعمدة مرة واحدة شاهد المرفق Sub UnMerge_Rng() ' Application.ScreenUpdating = False End_Row = ActiveSheet.Range("B" & Rows.Count).End(xlUp).Row + 2 For Col = 1 To 10 Set Rng = Range(Cells(5, Col), Cells(End_Row, Col)) With Rng .MergeCells = False .SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C" .Value = .Value End With Next Application.ScreenUpdating = True ' End Sub تقرير الطلاب1.xlsb

اخي شاهد المرفق ابريل20222.xlsm

رغم اني مع تبسيط راس الفاتورة ..لكن حسب طلبك انظر للمثال يمكن عن طريق جدول التسديد عمل تقرير للزبون بالمبالغ المسددة والمتبقية testQ.rar

فورم اكسل لانبياء الله ورسله باستخدام ال MultiPage الصفحات المتعددة تحميل الملف قصص الانبياء.xlsm قصص الانبياء.rar

بامكانك استخدام المعادلة ادناه والتعديل عليها حسب كل خلية حيث ان التنسيق من الاساس في الخلايا غير موحد =LEFT(A2,SEARCH(" ",A2))&" "&MID(A2,SEARCH(" ",A2,1)+1,SEARCH(" ",A2,SEARCH(" ",A2,1)+1)-SEARCH(" ",A2,1))&" "&RIGHT(A2,LEN(A2)-SEARCH(" ",A2,SEARCH(" ",A2,SEARCH(" ",A2)+1))) انظر للمرفق تصحيح مشكلة في الاسماء.xls