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

تدلل انشئ موديول واعطه مثلا الاسم basResizeControls وضع به الكود الاتى Option Compare Database Option Explicit ' Constants Const FONT_ZOOM_PERCENT_CHANGE As Double = 0.1 ' Percentage change for font zoom ' Variables Private fontZoom As Double ' Current font zoom level Private ctrlKeyIsPressed As Boolean ' Flag to indicate if the Ctrl key is pressed ' Enum to represent control tag indices Private Enum ControlTag FromLeft = 0 FromTop ControlWidth ControlHeight OriginalFontSize OriginalControlHeight End Enum ' Log error message to debug or a specified location Private Sub LogError(errMsg As String) ' Modify this part to log errors as needed, e.g., in a table or text file Debug.Print "Error: " & errMsg End Sub ' Save control positions to their Tag properties Public Sub SaveControlPositionsToTags(frm As Form) On Error GoTo ErrorHandler Dim ctl As Control Dim ctlLeft As String Dim ctlTop As String Dim ctlWidth As String Dim ctlHeight As String Dim ctlOriginalFontSize As String Dim ctlOriginalControlHeight As String For Each ctl In frm.Controls ctlLeft = CStr(Round(ctl.Left / frm.Width, 2)) ' Calculate relative left position ctlTop = CStr(Round(ctl.Top / frm.Section(ctl.Section).Height, 2)) ' Calculate relative top position ctlWidth = CStr(Round(ctl.Width / frm.Width, 2)) ' Calculate relative width ctlHeight = CStr(Round(ctl.Height / frm.Section(ctl.Section).Height, 2)) ' Calculate relative height ' Capture original font size and control height for specific control types Select Case ctl.ControlType Case acLabel, acCommandButton, acTextBox, acComboBox, acListBox, acTabCtl, acToggleButton ctlOriginalFontSize = ctl.FontSize ctlOriginalControlHeight = ctl.Height End Select ' Store the calculated values in the Tag property ctl.Tag = ctlLeft & ":" & ctlTop & ":" & ctlWidth & ":" & ctlHeight & ":" & ctlOriginalFontSize & ":" & ctlOriginalControlHeight Next ' Store proportional heights for header and footer sections frm.Section(acHeader).Tag = CStr(Round(frm.Section(acHeader).Height / (frm.Section(acHeader).Height + frm.Section(acDetail).Height + frm.Section(acFooter).Height), 2)) frm.Section(acFooter).Tag = CStr(Round(frm.Section(acFooter).Height / (frm.Section(acHeader).Height + frm.Section(acDetail).Height + frm.Section(acFooter).Height), 2)) Exit Sub ErrorHandler: LogError "SaveControlPositionsToTags: " & Err.Description Resume Next End Sub ' Reposition controls based on their stored Tag properties and current font zoom Public Sub RepositionControls(frm As Form, fontZoom As Double) On Error GoTo ErrorHandler Dim formDetailHeight As Long Dim tagArray() As String ' Calculate the detail section height formDetailHeight = frm.WindowHeight - frm.Section(acHeader).Height - frm.Section(acFooter).Height Dim ctl As Control For Each ctl In frm.Controls If ctl.Tag <> "" Then tagArray = Split(ctl.Tag, ":") ' Split the Tag property into an array If ctl.Section = acDetail Then ctl.Move frm.WindowWidth * CDbl(tagArray(ControlTag.FromLeft)), _ formDetailHeight * CDbl(tagArray(ControlTag.FromTop)), _ frm.WindowWidth * CDbl(tagArray(ControlTag.ControlWidth)), _ formDetailHeight * CDbl(tagArray(ControlTag.ControlHeight)) Else ctl.Move frm.WindowWidth * CDbl(tagArray(ControlTag.FromLeft)), _ frm.Section(ctl.Section).Height * CDbl(tagArray(ControlTag.FromTop)), _ frm.WindowWidth * CDbl(tagArray(ControlTag.ControlWidth)), _ frm.Section(ctl.Section).Height * CDbl(tagArray(ControlTag.ControlHeight)) End If ' Adjust font sizes for specific control types Select Case ctl.ControlType Case acLabel, acCommandButton, acTextBox, acComboBox, acListBox, acTabCtl, acToggleButton ctl.FontSize = Round(CDbl(tagArray(ControlTag.OriginalFontSize)) * (ctl.Height / CDbl(tagArray(ControlTag.OriginalControlHeight))) * fontZoom) End Select End If Next Exit Sub ErrorHandler: LogError "RepositionControls: " & Err.Description Resume Next End Sub ' Initialize the form by saving control positions Public Sub InitForm(frm As Form) On Error GoTo ErrorHandler fontZoom = 1 ' Set initial font zoom level SaveControlPositionsToTags frm Exit Sub ErrorHandler: LogError "InitForm: " & Err.Description Resume Next End Sub ' Handle the mouse wheel event to zoom in/out if Ctrl key is pressed Public Sub HandleMouseWheel(frm As Form, ByVal Page As Boolean, ByVal Count As Long) On Error GoTo ErrorHandler If ctrlKeyIsPressed Then If Count < 0 Then fontZoom = fontZoom + FONT_ZOOM_PERCENT_CHANGE ' Increase font zoom RepositionControls frm, fontZoom ElseIf Count > 0 Then fontZoom = fontZoom - FONT_ZOOM_PERCENT_CHANGE ' Decrease font zoom RepositionControls frm, fontZoom End If End If Exit Sub ErrorHandler: LogError "HandleMouseWheel: " & Err.Description Resume Next End Sub ' Handle the form resize event Public Sub HandleResize(frm As Form) On Error GoTo ErrorHandler ' Adjust header and footer heights proportionally frm.Section(acHeader).Height = frm.WindowHeight * CDbl(frm.Section(acHeader).Tag) frm.Section(acFooter).Height = frm.WindowHeight * CDbl(frm.Section(acFooter).Tag) RepositionControls frm, fontZoom Exit Sub ErrorHandler: LogError "HandleResize: " & Err.Description Resume Next End Sub ' Handle key up event to reset Ctrl key flag Public Sub HandleKeyUp() ctrlKeyIsPressed = False End Sub ' Handle key down event to manage font zooming with + and - keys Public Sub HandleKeyDown(frm As Form, KeyCode As Integer, Shift As Integer) On Error GoTo ErrorHandler Dim shiftKeyPressed As Boolean shiftKeyPressed = (Shift And acShiftMask) > 0 If shiftKeyPressed Then Select Case KeyCode Case vbKeyAdd fontZoom = fontZoom + FONT_ZOOM_PERCENT_CHANGE ' Increase font zoom RepositionControls frm, fontZoom KeyCode = 0 ' Prevent the "+" symbol from showing up in text boxes Case vbKeySubtract fontZoom = fontZoom - FONT_ZOOM_PERCENT_CHANGE ' Decrease font zoom RepositionControls frm, fontZoom KeyCode = 0 ' Prevent the "-" symbol from showing up in text boxes End Select End If ' Check if Ctrl key is pressed If (Shift And acCtrlMask) > 0 Then ctrlKeyIsPressed = True End If Exit Sub ErrorHandler: LogError "HandleKeyDown: " & Err.Description Resume Next End Sub وفى النموذج يتم الاستدعاء من خلال Private Sub Form_Load() Call InitForm(Me) End Sub Private Sub Form_MouseWheel(ByVal Page As Boolean, ByVal Count As Long) Call HandleMouseWheel(Me, Page, Count) End Sub Private Sub Form_Resize() Call HandleResize(Me) End Sub Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer) Call HandleKeyUp End Sub Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer) Call HandleKeyDown(Me, KeyCode, Shift) End Sub وان اردت اضافة DoCmd.Maximize فى الحدث Form_Load يمكنك ذلك

ادا كنت قد فهمت طلبك بشكل صحيح فهدا سيوفي بالغرض Sub CopyRanges() Dim i As Long, r As Long, a As Long, lr As Long Dim OneRng As Variant, arr As Variant Dim WS As Worksheet: Set WS = Sheets("شيت") Dim f As Worksheet: Set f = Sheets("نتيجةت1") a = WS.Range("A" & WS.Rows.Count).End(xlUp).Row lr = f.Columns("D:AD").Find(What:="*", _ SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row Application.ScreenUpdating = False For r = 14 To lr Union(f.Range("D" & r).Resize(, 14), f.Range("S" & r).Resize(, 12)).ClearContents Next r OneRng = Array("H8:I" & a, "L8:M" & a, "P8:Q" & a, "T8:U" & a, _ "X8:Y" & a, "AB8:AC" & a, "AF8:AG" & a, "AH8:AQ" & a, "AT8:AU" & a) arr = Array("D14", "F14", "H14", "J14", "L14", "N14", "P14", "S14", "AC14") For i = 0 To UBound(OneRng) WS.Range(OneRng(i)).Copy f.Range(arr(i)).PasteSpecial xlPasteValues Next Application.ScreenUpdating = True Application.CutCopyMode = False End Sub وفي ورقة (نتيجةت1) Private Sub Worksheet_Activate() CopyRanges End Sub New ورقة عمل Microsoft Excel .xlsb

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

السلام عليكم ورحمة الله وبركاته ، أخواني وأساتذتي ومعلمينا ( دون استثناء ) طبعاً المكتوب باين من عنوانه . هي اللعبة المعروفة والتي لعبها منا على الأغلب الجميع في طفولته .. من يبدأ اللعب هو من يحصل على أعلى رقم من القرعة . اللعبة يلعبها لاعبين اثنين فقط . يتم تسجيل النقاط لكل لاعب في خانة منفصلة . طريقة التحرك بنمط حجر النرد ( ولا أعلم إن كان البعض سيقول لي أن النرد حرام ) لكنه هنا ليس حجر نرد حقيقي وإنما فكرة اختيار عشوائي لصور أوجه حجر النرد ) الأرقام ) تدل على خطوات التقدم . الصعود لأعلى عند وصول اللاعب إلى أول السلم حتى الخانة التي تمثل رأس السلم . وكما الصعود !! سيكون لدينا النزول عند وصول اللاعب إلى رأس الثعبان سينزل باتجاه الذيل نزولاً .. تسجيل الحركات الإنتقالية لكل لاعب في مربع الحركات أسفل اللعبة . في حال الوصول إلى 95 سيحتاج اللاعب للوصول إلى الهدف 100 إلى 6 نقاط أو أقل ، فلو تقدم الى 99 كمثال هنا سيحتاج الى نقطة واحدة للتحرك وللفوز . فلو كان الاختيار العشوائي للصورة فرضاً 4 فلا يتم تحقيق الفوز إلا بالرقم 1 .... وهكذا . عند فوز أحد اللاعبين ، سيتحول الزر إلى لعبة جديدة . إمكانية تكبير النموذج لملئ الشاشة أو لا ، حسب رغبتك صور من اللعبة :- ملف اللعبة مفتوح المصدر Snake3.accdb

استاذ خليفه اشكرك على سرعة الاستجابه , بارك الله بك تفضل 🌹

ما شاء الله تبارك الله .... حاجه عظمة .... بارك الله فيك بشمهندس @Foksh

ما شاء الله تبارك الرحمن مهندس @Foksh روعة الفكرة وجمال التنفيذ .. لله درك 🙂👌 أقترح عليك (مجرد اقتراح 😁🖐) .. - أضافة أصوات تفاعلية للعبة لإضافة المزيد من الحماس التفاعلي .. وخصوصا عنا ارتقاء السلالم أو عند لدغات الأفاعي 🙂 . - إظهار حركة تقدم اللاعبين حين الإنتقال من مربع لآخر لإزالة الجمود من اللعبة. وأما الباقي فبسم الله عليك من الحسد

بطريق آخر ،، المهم نجاح الفكرة و وصولك الى حل يعالج مشكلتك ، بالتوفيق أستاذ @عبد الله قدور

بعد جهد في هذا المجال وصلت الى قناعة ان المشكلة في تعريف المتغير من نوع date هذا المتغير ما ان تم استخدامه فان التاريخ المعتمد هو شهر يوم سنة فإذا فشل في اعتماد ذلك اعتمد يوم شهر سنة فوصلت لحل هو عدم استخدام المكتبة date ابدا قمت بتحويل التاريخ الى رقم على الشكل التالي تاريخ 01/05/2024 الى 20240501 هكذا يحافظ هذا الرقم على نفس ترتيب التواريخ واستخدم متغير من نوع long بدلا من date ووضعت العمود في جدول وجعلته محسوب كما في الصورة والنتيجة كانت ولتذهب مكتبة date بما فيها الى الجحيم

الموضوع ليس بالقديم جداً ، ولكني انصحك بفتح موضوع جديد وإرفاق ملفك الذي تريد التعديل عليه

أخي الكريم @أمير ادم ، قمت بتعديل جذري على فكرتك بحيث ابتعدت عن الاعتماد على موقع يقوم بإنشاء كود QR ، واستعنت ببرنامج صغير يدعم اللغة العربية أيضاً ، وأعدت صياغة الكود كما يلي ، مع العلم أن المشكلة لديك كانت في تنسيق مربع النص AD_Invoice_Time_and_Date .. تفضل تجربتي وأخبرني بالنتيجة QR.zip

تفضل FinancialPrg9.rar

الصديق والخبير الفاضل Foksh شكرا لك

مشاركة جانبية متأخرة مع الأساتذة ( أن تصل متأخراً خير من أن لا تصل ابدأ )، جرب هذه الفكرة اخي @عبد الله قدور ، ننشئ دالة عامة في مديول ونستخدم هذا الكود الذي يعيد تنسيق التاريخ بالشكل DD/MM/YYYY :- Public Function ParseDate(inputDate As String) As Date Dim dayPart As String Dim monthPart As String Dim yearPart As String dayPart = Mid(inputDate, 1, 2) monthPart = Mid(inputDate, 4, 2) yearPart = Mid(inputDate, 7, 4) ParseDate = DateSerial(CInt(yearPart), CInt(monthPart), CInt(dayPart)) End Function ونستدعيه على سبيل المثال كالآتي ( المتغير اختياري وعلى سبيل المثال ) :- Dim myDate As Date myDate = ParseDate("24/05/2024") ودمتم 🤗

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

يمكنكم الاطلاع على هذا المرفق https://www.officena.net/ib/applications/core/interface/file/attachment.php?id=129345

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

بص يا صديقي .. الآن انت عندك List Box وأكيد مصدر بياناته استعلام على ما أعتقد !! انت تستبدل اسم F_Name بالاسم ده في كود الرسالة.. Me.F_Name.Column(1) جرب واديني خبر

أنظر هنا أستاذ @عبد الله قدور 🙂

يسعدنا حصولك على النتيجة المطلوبة لاكن للفائدة فقط لا غير . من الممكن تبسيط الكود لاكن هناك احتمالات واردة ربما لم تقم بتجربتها مثلا كالبحث عن قيمة فريدة او رقم يتضمن قيمة عشرية الكود الخاص بي تم انشاءه لتطابق القيم ليس للبحث بالتشابه هدا لانك طلبت البحث بجميع الاعمدة عن قيمة معينة او ربما لم استوعب طلبك جيدا .لقد فكرت مسبقا في اقتراح استادنا الغالي @حسونة حسين لاكن للاسف يعطي اخطاء جرب ادخال قيمة غير مكررة او تاريخ غير مكرر والبحث عنها او البحث عن رقم مثلا 3.530 ستلاحظ انه تم اظهار رسالة عدم تواجده . او تكراره في عدة اعمدة رغم وجوده مرة واحدة فقط على الملف بالتوفيق.......... جديد (1).xlsm

وعليكم السلام ورحمه الله وبركاته تفضل اخى جرب هذا التعديل Option Explicit Private Sub CommandButton1_Click() Dim Ws As Worksheet, CEl As Range, Sheets_name As Variant, Sh, Temp() Dim Str As String, i As Long, j As Long, Lr As Long Str = Me.TextBox1.Value Sheets_name = Array("عين غزال", "الجبيهة", "الجبيهة", "أربد", "الزرقاء") i = 0 For Each Sh In Sheets_name Set Ws = ThisWorkbook.Sheets(Sh) Lr = Ws.Cells(Ws.Rows.Count, 9).End(xlUp).Row For Each CEl In Ws.Range("A2:J" & Lr) If InStr(CEl.Value, Str) > 0 Then i = i + 1 ReDim Preserve Temp(1 To 12, 1 To i) For j = 1 To 10 Temp(j, i) = Ws.Cells(CEl.Row, j).Value Next j Temp(11, i) = Ws.Name Temp(12, i) = CEl.Address End If Next CEl Next Sh If i = 0 Then MsgBox "ما تحاول البحث عنه غير موجود في الاسواق ", vbInformation + vbSystemModal, "نظام البطاقات الائتمانية - Search " TextBox1.Text = "" Else Temp = Application.Transpose(Temp) With Me.ListBox1 .ColumnCount = 12 .ColumnWidths = "96,96,96,96,140,96,96,96,96,96,96,96" .Clear .List = Temp End With End If End Sub جديد.xlsm

Sub PDF_شيت_ترم_2() Dim FSO As Object Dim S(1) As String Dim sNewFilePath As String Dim Row As Long Set FSO = CreateObject("Scripting.FileSystemObject") S(0) = ThisWorkbook.FullName If FSO.FileExists(S(0)) Then S(1) = FSO.GetExtensionName(S(0)) If S(1) <> "" Then S(1) = "." & S(1) Set WS = ActiveSheet lastRow = WS.Columns("A:A").Find(What:="*", _ SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row With WS.PageSetup .PrintArea = "$A$3:$CH$" & lastRow End With sNewFilePath = ThisWorkbook.Path & "\شيت الصف السادس ترم ثان.pdf" WS.ExportAsFixedFormat Type:=xlTypePDF, Filename:=sNewFilePath, _ Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False End If Else MsgBox "لم يتم حفظ الملف ..يوجد خطأ ما " End If Sheets("شيت2").Activate Set FSO = Nothing ' mainy m = MsgBox("تم تصدير الشيت خارج الشيت بإسم شيت الصف السادس ترم ثان" & vbNewLine _ & "هذا الملف موجود فى نفس مكان برنامج الكنترول شيت", _ vbOKOnly + vbInformation + vbDefaultButton1 + vbApplicationModal + vbMsgBoxRight, _ "تم تصدير شيت صف السادس ترم 2 بصيغة pdf.") End Sub

افضل برنامج حضور وانصراف من تصميمى وهذا العمل كصدقه جارية على روح ابى ارجو له بالدعاء مميزات البرنامج 1- حفظ الشهور فى نفس الملف 2- حساب رصيد الاجازات المتبقى والعارضة 3- اضافة الاجازات والاعياد واماكنية تعديلها على السنه كلها ملحوظة التعديل او اضافة اى موظف من خلال الاعدادات وكذلك رصيد الاجازات حضور وانصراف.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته بعد ادن الاستاد المحترم @محمد حسن المحمد تفضل جرب اخي Sub Total_amount() Dim WS As Worksheet, Dest As Worksheet: Set WS = Sheets("Sheet1"): Set Dest = Sheets("التجميع بدون تكرار") a = WS.Range("B1").CurrentRegion.Value Dim c() ReDim c(1 To UBound(a, 1), 1 To UBound(a, 2)) Cpt = 1 Set mondico = CreateObject("Scripting.Dictionary") Application.ScreenUpdating = False For i = 1 To UBound(a) temp = a(i, 1) & a(i, 2) If Not mondico.exists(temp) Then mondico.Add temp, "" For k = 1 To UBound(a, 2) - 1: c(Cpt, k) = a(i, k): Next k c(Cpt, k) = c(Cpt, k) + a(i, k) Cpt = Cpt + 1 Else j = Application.Match(temp, mondico.keys, 0) col = UBound(a, 2) c(j, col) = c(j, col) + a(i, col) End If Dest.[B1:D1000] = Empty Next Dest.[B1].Resize(mondico.Count, UBound(a, 2)) = c End Sub كود تجميع .xlsb

بما انك مستجد على اكسس فانصحك باتباع الطرق الصحيحة عند كتابة العناصر وكافة الكائنات بحروف انجليزية حتى لو ان المعنى عربي من اجل يسهل عليك قراءة وفهم الاكواد ايضا من الاشياء الجميلة تمييز كائنات قاعدة البيانات عن بعضها بحيث انك حين ترى الاسم داخل الأكواد تعرف انه جدول او استعلام او نموذج او تقرير بحيث نكتب بادئة الاسم على النحو التالي : tbl للجداول qry للاستعلامات frm للنماذج reb للتقارير تم التعديل وعمل اللازم لا حظ انك لن تتمكن من فتح والدخول الى نموذج المستخدمين الا اذا دخلت باسم Bassam تجريب2.rar

tafkeet Ywmyat Mohasb .rar

بعد إذن أخى وحبيبى ومعلمى القدير أ / محمد الريفى عله يفى بالغرض AdvancedFilterDates.rar

السلام عليكم اتفضل استاذنا معادلة صفيف =IFERROR( INDEX($A$2:$D$902; MATCH(SMALL(IF(($A$2:$A$902>=$G$1)*($A$2:$A$902<=$G$2);ROW($A$2:$A$902);"");ROW($A1));ROW($A$2:$A$902);0); COLUMN(A$1)); "") ابايوسف.rar

السلام عليكم اخي العزيز محمد حسن اليك ملف فيه الاثنين بالمعادلات والاكواد العمل للاساتذة الكرام ارجو ان يكون هو المطلوب .. تحياتي كشف حساب بالمعادلات والاكواد.rar