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

وعليكم السلام ورحمة الله تعالى وبركاته =IFERROR(VLOOKUP(E13, $Q$12:$U$14, MATCH(D13, $Q$11:$U$11, 0), FALSE), "") New Microsoft Excel Worksheet.xlsx

انا مع هذا الرأي وسبب المشكلة السابقة عند الاستاذ عبداللطيف ويمكن ان يقع فيها البعض .. ان النتيجة تظهر في الاستعلامات ( معتمدة على السعر في جدول الاصناف) ولا يتم رصد السعر المسبق في جدول التفاصيل وفكرة الأخ gavan جيدة بعمل متوسطات للأسعار .. فإذا كانت نسبة الربح محددة يمكن ضبط متوسطات الشراء وايضا متوسطات البيع

السلام عليكم الموضوع قديم من 2016 لا اعرف ان كان السيد صالح وجد الحل يوجد عدة طرق في جعل النمودج شفاء دون تاثير على مكونات الاخرى كالازرار وليبلات وغيرها فانا من محبي الاكواد البسيطة لان الاكسس لايتحمل والكود يمكن ان تستدعيه من اي نمودج والكـــود عبارة عن موديول بسيط جدا يممكنك استخدامه لاي نمودج تريد لتوضيح فقط لبعض الاخوة كود استدعاء الموديول يجب تغيير لون خلفية نمودج كما موجود في كود ان وضعت لون احمر في الكود فنفس الشيء في خلفية النمودج ويجب ان تكون الصورة بامتداد ( Png,Gif ) مثل الصورة الموجودة في النمودج وليس شرط ان تضع الصورة في نمودج يمكنك من جعل خلفية النمودج صورة فورم شفــاف.accdb

فعلا عاجز عن الشكر جزاكم الله كل خير

فضل استاذ @تامر خليفه المرفق بعد التعديل بالجدول الجديد . QR_Code - بتسجيل العناصر بمحرر الأكواد.rar

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

ما شاءالله ،الف الف الف شكر لحضرتك👍👍👍👍👍👍

استاذ @Foksh جزاك الله تعالى كل خير وهو المطلوب شكراً جزيلاً

نعم تماما نموذج جدولي اقصد ورقة بيانات

تفضل استاذ @gavan التعديل بطلبك . GavanDB.rar

هل هذا ما تقصده ؟؟ SELECT TIP.*, TSHM.*, TSHY.[id] AS TSHY_id, TSHY.*, Ttipr.[id] AS Ttipr_id, Ttipr.*, Tmsr.[id] AS Tmsr_id, Tmsr.[No], Tmsr.[اسم المادة], Tmsr.[مبلغ الصرف], Tmsr.data, Tmsr.Year FROM ((((TIP LEFT JOIN TSHM ON TIP.id = TSHM.[id]) LEFT JOIN TSHY ON TIP.id = TSHY.[id]) LEFT JOIN Ttipr ON TIP.id = Ttipr.[id]) LEFT JOIN Tmsr ON TIP.id = Tmsr.[id]);

تفضل استاذ @تامر خليفه المرفق بعد التعديل ليعمل على النواتين 32بت و 64بت . QR_Code.rar

نفضل استاذ @تامر خليفه يالاستعانة بكود أحد الزملاء للاسف مادري اسمه ممكن يكون من النت أو من المنتدى . علما بأني أعمل على اوفيس 2010 32 بت .... اليك المرفق . QR_Code.rar

تفضل فكرتي المتواضعة ، حيث سيتم أولاً تحميل أسماء الاستعلامات في الليست بوكس ، وانت تختار ما تريده ، ثم انقر الزر للتصدير :- Private Sub Export_Selected_Queries() Dim xlApp As Object, xlWorkbook As Object, xlWorksheet As Object Dim db As DAO.Database, rs As DAO.Recordset Dim sheetIndex As Integer, colIndex As Integer, rowIndex As Integer Dim filePath As String, queryName As String Dim i As Variant filePath = Application.CurrentProject.Path & "\تقرير_الاكسيل.xlsx" If Me.Que_List.ItemsSelected.Count = 0 Then MsgBox "يرجى تحديد استعلام واحد على الأقل قبل التصدير", vbExclamation + vbMsgBoxRight, "خطأ" Exit Sub End If Set xlApp = CreateObject("Excel.Application") xlApp.Visible = True Set xlWorkbook = xlApp.Workbooks.Add Set db = CurrentDb sheetIndex = 1 For Each i In Me.Que_List.ItemsSelected queryName = Trim(Me.Que_List.ItemData(i)) Set rs = db.OpenRecordset(queryName, dbOpenSnapshot) If sheetIndex <= xlWorkbook.Sheets.Count Then Set xlWorksheet = xlWorkbook.Sheets(sheetIndex) Else Set xlWorksheet = xlWorkbook.Sheets.Add End If xlWorksheet.Name = queryName colIndex = 1 With xlWorksheet For Each fld In rs.Fields .Cells(1, colIndex).Value = fld.Name .Cells(1, colIndex).Font.Bold = True colIndex = colIndex + 1 Next fld rowIndex = 2 Do While Not rs.EOF colIndex = 1 For Each fld In rs.Fields .Cells(rowIndex, colIndex).Value = fld.Value colIndex = colIndex + 1 Next fld rowIndex = rowIndex + 1 rs.MoveNext Loop End With rs.Close sheetIndex = sheetIndex + 1 Next i xlWorkbook.SaveAs filePath xlWorkbook.Close xlApp.Quit On Error Resume Next Set rs = Nothing Set db = Nothing Set xlWorksheet = Nothing Set xlWorkbook = Nothing Set xlApp = Nothing On Error GoTo 0 MsgBox "تم تصدير البيانات بنجاح", vbInformation + vbMsgBoxRight, "نجاح العملية" End Sub test.accdb

يعطيك الف عافيه .. بانتظار الملف المفتوح الله يسعدك ..

رمضان كريم اول موقع ويب تفاعلي امساكية شهر رمضان 2025 https://ramdan2025.netlify.app/ من تصميمي لطلب السورس كود : 01159298568

السلام عليكم كود للاخ @صالح حمادي ملائمة عناصر النموذج في وضع ملأ الشاشة https://www.officena.net/ib/topic/74453-ملاءمة-عناصر-النموذج-في-وضع-ملأ-الشاشة/ تم التعديل عليه قليلا للتلائم العناصر مع حجم الشاشة من حيث (حجم الخط) و(تعديل خصائص العناصر) Option Compare Database Option Explicit Function ResizeForm(frm As Form) On Error GoTo ErrorHandler Dim X As Long, Y As Long, x1 As Long, Y1 As Long Dim moyH As Double, moyW As Double Dim obj As Control Dim maxFontSize As Integer Dim newFontSize As Double maxFontSize = 20 ' الحد الأقصى لحجم الخط ' أبعاد النموذج قبل التكبير X = frm.InsideWidth ' عرض النموذج قبل التكبير Y = frm.InsideHeight ' ارتفاع النموذج قبل التكبير ' تكبير النموذج DoCmd.Maximize ' أبعاد النموذج بعد التكبير x1 = frm.InsideWidth ' عرض النموذج بعد التكبير Y1 = frm.InsideHeight ' ارتفاع النموذج بعد التكبير ' حساب معامل الارتفاع والعرض moyH = Y1 / Y moyW = x1 / X ' تعديل خصائص كل عنصر في النموذج For Each obj In frm.Controls With obj ' ضبط الموضع والحجم .Left = .Left * moyW .Top = .Top * moyH .Width = .Width * moyW .Height = .Height * moyH ' تعديل حجم الخط إذا كان العنصر يدعم ذلك If .ControlType = acTextBox Or .ControlType = acLabel Or .ControlType = acCommandButton Or .ControlType = acComboBox Then If Not IsNull(.FontSize) Then newFontSize = .FontSize * moyH If newFontSize > maxFontSize Then .FontSize = maxFontSize ElseIf newFontSize < 6 Then .FontSize = 6 ' الحد الأدنى لحجم الخط Else .FontSize = newFontSize End If End If End If End With Next obj Exit Function ErrorHandler: MsgBox "حدث خطأ: " & Err.Description, vbCritical End Function اتمنى تجربته على شاشات ذات دقة مختلفة واخبارنا بالنتيجة تحياتي للجميع ملاءمة عناصر النموذج حسب حجم النموذج_.accdb

وعليكم السلام ورحمة الله تعالى وبركاته Sub MergeTotal() Dim WS As Worksheet, crWS As Worksheet, LastRow As Long, Irow As Long On Error Resume Next Set crWS = Sheets("total") On Error GoTo 0 If crWS Is Nothing Then MsgBox " غير موجودة total ورقة ", vbInformation Exit Sub Else Application.ScreenUpdating = False crWS.Range("A2:O" & crWS.Rows.Count).Clear End If Irow = 2 For Each WS In ThisWorkbook.Sheets If WS.Name <> crWS.Name Then LastRow = WS.Cells(WS.Rows.Count, 1).End(xlUp).Row If LastRow >= 2 Then WS.Range("A2:O" & LastRow).Copy crWS.Cells(Irow, 1).PasteSpecial Paste:=xlPasteAllUsingSourceTheme Irow = crWS.Cells(crWS.Rows.Count, 1).End(xlUp).Row + 1 End If End If Next WS Application.CutCopyMode = False Application.ScreenUpdating = True End Sub or Sub MergeTotal() Dim WS As Worksheet, Src As Worksheet Dim OnRng As Variant, rng As Range, r As Range Dim lastRow As Long, tmp As Long, col As Integer Set WS = Sheets("total") Application.ScreenUpdating = False lastRow = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row If lastRow > 1 Then: WS.Rows("2:" & lastRow).Clear tmp = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row + 1 For Each Src In ThisWorkbook.Sheets If Src.Name <> WS.Name Then OnRng = Src.Range("A2:O" & Src.Cells(Src.Rows.Count, "A").End(xlUp).Row).Value WS.Cells(tmp, 1).Resize(UBound(OnRng, 1), UBound(OnRng, 2)).Value = OnRng For lastRow = 1 To Src.Cells(Src.Rows.Count, "A").End(xlUp).Row WS.Rows(tmp + lastRow - 1).RowHeight = 18.5 Next lastRow tmp = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row + 1 End If Next Src With WS.Range("A1:O" & WS.Cells(WS.Rows.Count, "A").End(xlUp).Row) .Borders.LineStyle = xlContinuous: .HorizontalAlignment = xlCenter: .VerticalAlignment = xlCenter End With Application.ScreenUpdating = True End Sub الرواتب.xlsb

وجهة نظر 😇 تقصد اي تعديل جديد بالاضافة او الازالة جدول + نماذج ! يعتبر تحديث وفصل القديم بتصحيحات فقط نماذج = خطأ 😁 التحديث بالكمية او بتغيرات او يكون بالسنة لطلبات محدده برقم FE BE القديم يشمل كل من التعديلات والاضافات وتصحيحات (0)- اختيار نوع التحديث + INFO App Customer V?! + New date + Number Update انواع : (1)- تحديث متكامل 1- نموذج استبدال كل FE (Path one Onle New) = At Open FE Old Frist Chack IF Update = Run Link db K 2- الحاق البيانات القديمية الى الفارغ الجديد الجدوال - استخدم DOA Path db_New To Path db_Old ' SQL = SELECT MSysObjects.Name FROM MSysObjects WHERE (((MSysObjects.Type)=1 Or (MSysObjects.Type)=4 Or (MSysObjects.Type)=6) AND ((InStr([Name],"~"))=0) AND ((InStr([Name],"MSys"))=0)); For Each Tb In Next 'Updat = Selected Update =-1 rs.Close db1.Clos db2.colse او فقط تمرير السكول في الجدول ============================= (2)- تحديث تصحيح النماذج او الجداول فقط استبدال النماذج الحاق ثم استبدال بتغير المسار جديد للجداول ============================= (3)- تحديث الجداول الارتباط و تحديث جداول العامة او ارتباط بالجداول الخاصة كعداداة لنظام (4)- عند الانتهاء سؤال هل ترغب بالتشغيل التحديث + كل التحديثات في جدول مرتبط يتضمن جدول كافة التحديثات ويكون اما في(( السرفر او باي مسار )) اذا يسمح المركز ان يتم التحدث اولا كموافقة User = K1 And K2 Form Date < Today Run Update