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

ياليت توصف مهمة هذا الكود عشان نتوصل لحل و تفضل هذه المحاولة تكويد.accdb

انشئ Module جديد و الصق الشفرة التالية فيه Option Explicit Public Function StartTimer(NumberOfSeconds As Variant, ReportName As String) On Error Resume Next Dim PauseTime, Start, Finish, TotalTime PauseTime = NumberOfSeconds Start = Timer Do While Timer < Start + PauseTime DoEvents Loop Finish = Timer TotalTime = Finish - Start DoCmd.Close acReport, ReportName, acSaveYes End Function في ازرار فتح التقرير و بعد أمر فتح التقرير اعطي الأمر لتشغيل التايمر / المؤقت بعد اعطائه عدد الثواني و اسم التقرير StartTimer(«NumberOfSeconds»; «ReportName») مرفق التعديل tbl.accdb

السلام عليكم. أفتقد هذا المنتدى لأنني لم أزوره منذ فترة طويلة. كما هو معلوم خاصية التمرير باستخدام عجلة الماوس غير متاحة على اليوزرفورم رغم أنها خاصية مهمة ومطلوبة . لقد كتبت مؤخرا هذا الكود لحل هذه المشكلة ... الكود عام ويشتغل على يوزرفومات متعددة . الكود سهل الاستعمال حيث يمنح للمستعمل الحدث التالي الذي يكون موجودا داخل موديول الفورم والذي يعطي للمستعمل كل التحكم ملف للتحميل تعريف الحدث هو كالتالي: Public Sub OnMouseWheelScroll( _ ByVal UserForm As Object, _ ByVal obj As Object, _ ByVal WheelRotation As WHEEL_ROTATION, _ ByVal CtrlKey As CTRL_KEY_PRESS_STATE, _ ByVal X As Long, _ ByVal Y As Long, _ ByRef Cancel As Boolean _ ) على كل- الكود بأكمله على النحو التالي: 1 - كود في موديول عادي : Option Explicit Public Enum CTRL_KEY_PRESS_STATE Released Pressed End Enum Public Enum WHEEL_ROTATION Forward Backward End Enum Private Type POINTAPI X As Long Y As Long End Type Private Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type #If Win64 Then Private Type MSG hwnd As LongLong message As Long wParam As LongLong lParam As LongLong time As Long pt As POINTAPI End Type #Else Private Type MSG hwnd As Long message As Long wParam As Long lParam As Long time As Long pt As POINTAPI End Type #End If #If VBA7 Then #If Win64 Then Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal arg1 As LongLong, ppacc As Any, pvarChild As Variant) As Long Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal Point As LongPtr) As LongPtr Private Declare PtrSafe Function PtInRect Lib "user32" (lpRect As RECT, ByVal arg2 As LongPtr) As Long #Else Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As Any, pvarChild As Variant) As Long Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As LongPtr Private Declare PtrSafe Function PtInRect Lib "user32" (lpRect As RECT, ByVal arg1 As Long, ByVal arg2 As Long) As Long #End If Private Declare PtrSafe Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hwnd As LongPtr) As Long Private Declare PtrSafe Function GetCursorPos Lib "user32.dll" (lpPoint As POINTAPI) As Long Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr) Private Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal nCmdShow As Long) As Long Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long Private Declare PtrSafe Function EnumWindows Lib "user32" (ByVal lpEnumFunc As LongPtr, ByVal lParam As LongPtr) As Long Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long Private Declare PtrSafe Function GetMessage Lib "user32" Alias "GetMessageA" (lpMsg As MSG, ByVal hwnd As LongPtr, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long) As Long Private Declare PtrSafe Function TranslateMessage Lib "user32" (lpMsg As MSG) As Long Private Declare PtrSafe Function DispatchMessage Lib "user32" Alias "DispatchMessageA" (lpMsg As MSG) As LongPtr Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long Private Declare PtrSafe Function GetClientRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long Private Declare PtrSafe Function ScreenToClient Lib "user32" (ByVal hwnd As LongPtr, lpPoint As POINTAPI) As Long Private Declare PtrSafe Function GetAncestor Lib "user32" (ByVal hwnd As LongPtr, ByVal gaFlags As Long) As LongPtr Private Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer Private hwnd As LongPtr, hObjUnderMouse As LongPtr, lPtr As LongPtr #Else Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long Private Declare Function AccessibleObjectFromPoint Lib "Oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As IAccessible, pvarChild As Variant) As Long Private Declare Function PtInRect Lib "user32" (lpRect As RECT, ByVal arg1 As Long, ByVal arg2 As Long) As Long Private Declare Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hwnd As Long) As Long Private Declare Function GetCursorPos Lib "user32.dll" (lpPoint As POINTAPI) As Long Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long) Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long Private Declare Function EnumWindows Lib "user32" (ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long Private Declare Function GetMessage Lib "user32" Alias "GetMessageA" (lpMsg As MSG, ByVal hwnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long) As Long Private Declare Function TranslateMessage Lib "user32" (lpMsg As MSG) As Long Private Declare Function DispatchMessage Lib "user32" Alias "DispatchMessageA" (lpMsg As MSG) As Long Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long Private Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long Private Declare Function GetAncestor Lib "user32" (ByVal hwnd As Long, ByVal gaFlags As Long) As Long Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer Private hwnd As Long, hObjUnderMouse As Long #End If Private oCurrentUserForm As Object, oCurrentIgnoreList As Variant Private oCollection As Collection Private objUnderMouse As Object Private WheelRotation As WHEEL_ROTATION Private CtrlKey As CTRL_KEY_PRESS_STATE Private tMsg As MSG Private tCurPos As POINTAPI, tPt As POINTAPI, tWinRect As RECT, tClient As RECT Private oIA As IAccessible, oIACtrl As IAccessible, oIAPage As IAccessible Private oTempCtrl As Control, oCtrl As Control, oTempPage As Control Private vKid As Variant Private lLeft As Long, lTop As Long, lAccResult As Long, lPtInRectlResult As Long, i As Long Private bCancel As Boolean Public Property Let EnableWheelScroll(ByVal UserForm As Object, Optional IgnoreList As Variant, ByVal Enable As Boolean) Call KillTimer(hwnd, 0) If Enable = False Then Set oCollection = Nothing Else Set oCurrentUserForm = UserForm oCurrentIgnoreList = IgnoreList Call IUnknown_GetWindow(UserForm, VarPtr(hwnd)) Set oCollection = New Collection Call SetTimer(hwnd, 0, 0, AddressOf TimerProc) End If End Property '________________________________PRIVATE SUBS___________________________________ Private Sub TimerProc() Const SCROLL_CHANGE = 20 ' <== Change Const as required '// '///////////////////////////////////////////////////////////// Const CHILDID_SELF = &H0& Const S_OK As Long = &H0 Const WM_NCLBUTTONDOWN = &HA1 Const WM_TIMER = &H113 Const WM_MOUSEWHEEL = &H20A Const WHEEL_DELTA = 120 Const PM_REMOVE = &H1 Const MK_CONTROL = &H8 Const GA_ROOT = 2 Const POINTSPERINCH As Long = 72 Const LOGPIXELSX As Long = 88 Const LOGPIXELSY As Long = 90 On Error Resume Next 'RETRIEVE AND STORE THE LOCATION OF EACH CONTROL. For Each oIACtrl In oCurrentUserForm.Controls Set oTempCtrl = oIACtrl If IsError(Application.Match(TypeName(oTempCtrl), oCurrentIgnoreList, 0)) Then Call oIACtrl.accLocation(lLeft, lTop, 0, 0, CHILDID_SELF) If TypeName(oTempCtrl) = "MultiPage" Then Set oIAPage = oTempCtrl.Pages(oTempCtrl.Value) Call oIAPage.accLocation(lLeft, lTop, 0, 0, CHILDID_SELF) Set oTempPage = oIAPage oCollection.Add oTempPage, CStr(lLeft & lTop & oTempCtrl.Name & oTempCtrl.Pages(oTempCtrl.Value).Caption) End If oCollection.Add oTempCtrl, CStr(lLeft & lTop) End If Next 'RETRIEVE ELEMENTS UNDER THE MOUSE POINTER. Call GetCursorPos(tCurPos) Call GetWindowRect(hwnd, tWinRect) #If Win64 Then Call CopyMemory(lPtr, tCurPos, LenB(tCurPos)) lAccResult = AccessibleObjectFromPoint(lPtr, oIA, vKid) hObjUnderMouse = WindowFromPoint(lPtr) lPtInRectlResult = PtInRect(tWinRect, lPtr) #Else lAccResult = AccessibleObjectFromPoint(tCurPos.X, tCurPos.Y, oIA, vKid) hObjUnderMouse = WindowFromPoint(tCurPos.X, tCurPos.Y) lPtInRectlResult = PtInRect(tWinRect, tCursPos.X, tCursPos.Y) #End If 'EXIT TIMER PROC IF MOUSE OUTSIDE FORM RECT. If lPtInRectlResult = 0 Then Call KillTimer(hwnd, 0) GoTo Xit End If If lAccResult = S_OK Then Call oIA.accLocation(lLeft, lTop, 0, 0, CHILDID_SELF) Set objUnderMouse = oCollection.Item(lLeft & lTop) If GetAncestor(hObjUnderMouse, GA_ROOT) <> hwnd Then If TypeName(objUnderMouse) <> "ComboBox" Then Exit Sub End If End If For Each oCtrl In oCurrentUserForm.Controls If TypeName(oCtrl) = "MultiPage" Then Set objUnderMouse = oCollection.Item(lLeft & lTop & oCtrl.Name & oCtrl.Pages(oCtrl.Value).Caption) End If Next If oIA.accName(CHILDID_SELF) = oCurrentUserForm.Caption Then Set objUnderMouse = oCurrentUserForm End If 'WAIT FOR A MOUSEWHEEL-SCROLL AND RAISE THE SCROLL PSEUDO-EVENT WHEN IT HAPPENS. If Not objUnderMouse Is Nothing Then Call GetMessage(tMsg, 0, 0, 0) 'EXIT TIMER PROC WHEN MOVING THE FORM. If tMsg.message = WM_NCLBUTTONDOWN Then Call KillTimer(hwnd, 0) Call TranslateMessage(tMsg) Call DispatchMessage(tMsg) GoTo Xit End If tPt = tMsg.pt Call GetClientRect(hwnd, tClient) Call ScreenToClient(hwnd, tPt) If GetAsyncKeyState(vbKeyLButton) = 0 And tPt.Y <= 0 Then Call KillTimer(hwnd, 0) GoTo Xit End If 'EXIT TIMER PROC WHEN MOVING THE FORM. If tPt.Y <= 0 Then If tMsg.message = WM_TIMER Then Call KillTimer(hwnd, 0) Call TranslateMessage(tMsg) Call DispatchMessage(tMsg) GoTo Xit End If End If If tMsg.message = WM_MOUSEWHEEL Then CtrlKey = IIf(loword(CLng(tMsg.wParam)) = MK_CONTROL, Pressed, Released) If (hiword(CLng(tMsg.wParam)) / WHEEL_DELTA) > 0 Or (hiword(CLng(tMsg.wParam)) = WHEEL_DELTA) Then WheelRotation = Forward Else WheelRotation = Backward End If 'RAISE THE PSEUDO-SCROLL EVENT LOCATED IN THE oCurrentUserForm MODULE. Call oCurrentUserForm.OnMouseWheelScroll(oCurrentUserForm, objUnderMouse, WheelRotation, CtrlKey, tCurPos.X - lLeft, tCurPos.Y - lTop, bCancel) 'IF SCROLL EVENT NOT CANCELED FOR THE CURRENT CONTROL, GO AHEAD AND IMPLEMENT THE SCROLLING. If Not bCancel Then If TypeName(objUnderMouse) = "TextBox" Then With objUnderMouse .SetFocus If i = 0 Then .SelStart = 0 Else .SelStart = IIf(.SelStart = .LineCount, 0, .SelStart) End If If WheelRotation = Forward Then .CurLine = .CurLine - 1 Else .CurLine = IIf(.CurLine = .LineCount - 1, .CurLine, .CurLine + 1) End If End With i = i + 1 End If If TypeName(objUnderMouse) = "ScrollBar" Then With objUnderMouse If WheelRotation = Forward Then .Value = IIf(.Value - objUnderMouse.SmallChange > .Min, .Value - objUnderMouse.SmallChange, .Min) Else .Value = IIf(.Value + objUnderMouse.SmallChange < .Max, .Value + objUnderMouse.SmallChange, .Max) End If End With End If If TypeName(objUnderMouse) = "ListBox" Or TypeName(objUnderMouse) = "ComboBox" Then With objUnderMouse If CtrlKey = Released Then If WheelRotation = Forward Then .TopIndex = .TopIndex - 1 Else .TopIndex = .TopIndex + 1 End If Else .SetFocus If WheelRotation = Forward Then SendKeys "{LEFT}", True DoEvents SendKeys "{RIGHT}", True Else SendKeys "{RIGHT}", True DoEvents SendKeys "{RIGHT}", True End If End If End With End If If TypeName(objUnderMouse) <> "ComboBox" Then Call EnumWindows(AddressOf HideDropDown, ByVal 0) End If With objUnderMouse If CtrlKey = Released Then If WheelRotation = Forward Then .ScrollTop = Application.Max(0, .ScrollTop - SCROLL_CHANGE) Else .ScrollTop = Application.Min(.ScrollHeight - .InsideHeight, .ScrollTop + SCROLL_CHANGE) End If Else If WheelRotation = Forward Then .ScrollLeft = Application.Max(0, .ScrollLeft - SCROLL_CHANGE) Else .ScrollLeft = Application.Min(.ScrollWidth - .InsideWidth, .ScrollLeft + SCROLL_CHANGE) End If End If End With End If End If End If End If Call TranslateMessage(tMsg) Call DispatchMessage(tMsg) Exit Sub Xit: Call SetTimer(hwnd, 0, 0, AddressOf TimerProc) End Sub Private Function loword(DWord As Long) As Integer If DWord And &H8000& Then loword = DWord Or &HFFFF0000 Else loword = DWord And &HFFFF& End If End Function Private Function hiword(ByVal DWord As Long) As Integer hiword = (DWord And &HFFFF0000) \ &H10000 End Function #If Win64 Then Private Function HideDropDown(ByVal hwnd As LongLong, ByVal lParam As Long) As Long #Else Private Function HideDropDown(ByVal hwnd As Long, ByVal lParam As Long) As Long #End If Dim sClassName As String * 256 Call GetClassName(hwnd, sClassName, 256) If Left(sClassName, 2) = "F3" Then Call ShowWindow(hwnd, 0) HideDropDown = 0 Exit Function End If HideDropDown = 1 End Function 2 - كود في اليوزرفورم موديول Option Explicit Private Sub UserForm_Initialize() Dim i As Long For i = 1 To 100 Me.ListBox1.AddItem i Me.ComboBox1.AddItem i Next i End Sub Private Sub UserForm_Activate() EnableWheelScroll(Me) = True End Sub Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) EnableWheelScroll(Me) = False With Sheet1 .[a9].ClearContents .[a12].ClearContents .[a15].ClearContents .[a18].ClearContents .[a21].ClearContents .[a24].ClearContents .[a27].ClearContents End With End Sub Private Sub CommandButton1_Click() UserForm2.Show vbModeless End Sub Private Sub CommandButton2_Click() Unload Me End Sub '-------------------- 'Public Generic event 'Set the Cancel Argument to TRUE to disable scrolling Public Sub OnMouseWheelScroll( _ ByVal UserForm As Object, _ ByVal obj As Object, _ ByVal WheelRotation As WHEEL_ROTATION, _ ByVal CtrlKey As CTRL_KEY_PRESS_STATE, _ ByVal X As Long, _ ByVal Y As Long, _ ByRef Cancel As Boolean _ ) With Sheet1 If TypeName(obj) = "Page" Then .[a12] = obj.Parent.Name & "." & obj.Name Else .[a12] = obj.Name End If .[a9] = UserForm.Name .[a15] = IIf(WheelRotation = Forward, "Forward", "Backward") .[a18] = IIf(CtrlKey = Pressed, "Pressed", "Released") .[a21] = IIf(CtrlKey = Pressed, "Horizontal", "Vertical") .[a24] = X .[a27] = Y End With End Sub أتمنى أن يكون الكود مفيدا وإذا وجدت أي مشكلة ، فيرجى إبلاغي بذلك. وأخيرا أتقدم بسلام خاص للأستاذ الفاضل ياسر خليل من مصر الحبيبة الذي عرفني بهذا المنتدى

جرب هذي المحاولة الجمعية.accdb

تفضل هذه المحاولة ارجو ان تكون موفقة Database1.rar

وعليكم السلام-اجعل المعادلة بالعمود C هكذا =VALUE(B1&A1) TEST1.xlsx

طيب مشاركة مع حبايبنا الاساتذة ..... اظن هذه معروفة ..... صح ..... Private Sub BtnFalse_Click() ChkBox = False ChkBox.Requery DoCmd.SetWarnings False DoCmd.RunSQL "UPDATE t2 SET t2.[YesNo] = [Forms]![incom2]![ChkBox] WHERE (((t2.xuser)=[Forms]![incom2]![xuser]));" DoCmd.SetWarnings True End Sub Private Sub BtnTrue_Click() ChkBox = True ChkBox.Requery DoCmd.SetWarnings False DoCmd.RunSQL "UPDATE t2 SET t2.[YesNo] = [Forms]![incom2]![ChkBox] WHERE (((t2.xuser)=[Forms]![incom2]![xuser]));" DoCmd.SetWarnings True End Sub

اتفضل ابسط حل خانة الاختيار - 2.accdb

انشئ Module جديد و الصق فيه الشفرة التالية Public Function ReNumber() On Error Resume Next Dim db As DAO.Database Dim rs As DAO.Recordset Dim tdf As DAO.TableDef Dim x As Integer Dim sSQL As String Set db = CurrentDb For Each tdf In db.TableDefs If Not (tdf.Name Like "MSys*" Or tdf.Name Like "~*" Or tdf.Name Like "exl*") Then sSQL = "ALTER TABLE [" & tdf.Name & "] Add [ID_New] Number" db.Execute sSQL Set rs = CurrentDb.OpenRecordset(tdf.Name) If Not rs.BOF And Not rs.EOF Then rs.MoveFirst While (Not rs.EOF) x = x + 1 rs.Edit rs.Fields("ID_New") = x rs.Update rs.MoveNext Wend End If rs.Close Set rs = Nothing End If x = 0 Next MsgBox "تم اضافة ترقيم لجميع الجداول بنجاح", vbInformation + vbMsgBoxRight, "تأكيد" End Function و في النموذج ازرار اعادة ترقيم ضع الأمر التالي Call ReNumber

In cell K2 insert the formula then drag =ROUNDUP(C2,0)

أستاذ @alhellal hamd يبدوأن حضرتك ما قرأت آخر سطر في المشاركة الأولى

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

نعم تعمل بصورة ممتازة فأنا حاليا استخدمه و لا اواجه اي مشكلة نهائيا

كن في الحياة كشآرب القهوة !.. يستمتع بهــا رغم سوآدها ومرآرتهآ وتذكر قول الخشب للمسمار: لقد كسرتني وألمتني فرد المسمار قائلاً : لو كنت رأيت الدق فوق رآسي لكنت عذرتني فليعذر النآس بعضهم البعض فكل شخص لآيعرف ظروف الآخر إذآ إستمريت بـ هذه الحسآسية الزآئدة . . والحزن علي كل تصرف , فـ إنك ستحوّل حيآتك إلي جحيم ! تذكَر .. أن النآس تختلف في تفكيرهآ وطبآعهآ فما ترآه أنت جآرحاً .... قد يرآه غيرك أمراً تآفهاً هنآك موآقف مؤلمة قد تتعرض لهآ ولكن , إلي متي تجتر الموقف وتقف عليه ! إن أصآبك الألم ! عشه في لحظته .. ثم تجآوزه وكآفح من أجل تجاهله أشغل نفسك .. تنآسآه حتي يغيب عن ذآكرتك ! إحفظ لسانك أيها الإنسان لا يلدغـنـّك .. إنه ثعبان فكم في المقابرمن قتيل لسانه كانت تهاب لقاءه الشجعان وإذا حار أمرك في معنيين ولم تدرِ أين الخطا والصواب فخالف هواك فإن الهوى يقود النفوس إلى ما يعاب ولا تحاسب النآس عندما يخطئوآ ولا تذهب لغيرهم لتشكوا منهم .. لسانك لا تذكر به عورة امرئ فكلك عـورات وللــناس ألـســــــن وعينك إن أبدت إليك من الناس مساوءً فقل يا عيني للنـاس كذلك أعين واقضى حاجة المحتاج حتى لو كان اليك مسيئاً فأفضل الناس مابين الورى رجل تقضى على يده للناس حاجات لا تمنعن يد المعروف عن أحد ما دمت مقتدرا فالسعد تارات واشكر فضائل صنع الله إذ جعلت إليك لا لك عند الناس حاجات مهما إختفت من حياتك أمور ظننت أنها سبب سعادتك ! تأكد أن اللـه صرفها عنك قبل ان تكون سبباً في تعاستك عليك بتقوي الله ان كنت غافلاً أنظر لحالك كيف تعصاه ويأتيك بالارزاق من حيث لا تدري فكيف تخاف الفقر والله رازقاً فقد رزق الطير و الحوت في البحر و من ظن ان الرزق يأتي بقوة ما اكل العصفور شيئاً مع النسر تزول عن الدنيا فانك لا تدري اذا جنّ عليك الليل هل تعيش الي الفجر فكم من صحيح مات من غير علة و كم من سقيم عاش حيناً من الدهر وكم من فتي امسي و اصبح ضاحكاً وأكفانه في الغيب تنسج وهو لا يدري فمن عاش الفاً و الفيـــــــــــــن فلا بد من يوم يسير الـــــي القبـــــــــــر صافح وسامح .. ودع الخلق للخالق .. {فأنت****** .. وهم****** ..ونحن****** .. كلنا راحلوون إفعل الخير مهما استصغرته .. فلآ تدري أي حسنة تدخلك الجنةView the full article

بارك الله فيك ابا الحسن .... تقريرك المصدر هو بالانجليزي ... كيف تبغاه بالعربي ؟؟؟؟؟؟؟ ثانيا :::: لا تتوقع عند تصدير التقرير الى الاكسل يكون بنفس التنسيق .... اذا تبقاة بنفس التنسيق صدرة PDF فقط ...

معلمى / @ابا جودى حقك سوف يبطل العجب السبب بسيط جدا وهو ان عندى اكثر من حوالى ست نماذج بهم نفس العملية ومن غير المقول ان اعمل ست استعلامات

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

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

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

استاذى الحبيب الغالى لقلبى د.كاف يار طبقت كل المكتوب بالضبط ولا يتم ارجاع الترقيم التلقائى بارك الله فيك وبك ولك اللهم امين احترامى ترقيم تلقائى كود.accdb

ممكن مثال حي علشان فعلا مش شغاله اشتغلت عليها كتير وبردو مش شغاله تمام اشتغلت بس الرقم بيطلع غلط مثلا يوليو 2021 5 جمع بيطلع 3 فقط

الشكر لله خالص دعواتي بالتوفيق

الكود يقوم بتقسيم النص الى كلمات ويحجزها في مصفوفة ثم يقارن وحود كلمة او كلمتين متتاليتين في حقل جدول المقارنة نعم ممكن لكن الافضل مراعاة عدم تطابق بيانات الحقول فكلما كانت البيانات فريدة (غير مكررة) كلما كانت النتائج ادق يبحث لحد كلمتين لانه لو تلاحظ النتائج وجود كفر الشيخ نعم بعض النتائج لا تظهر وذلك لوجود مشكلة في النص جرب ان تكتب كلمات مثل البحر الاحمر وغيرها ولاحظ النتيجة نعم يتم اضافة شرط ثالث للكود لكن للامانة لم اجرب ElseIf Nz(DLookup("Column1", "Sheet2", "Column1='" & Trim(Arr(i)) & " " & Trim(Arr(i + 1)) & " " & Trim(Arr(i + 2)) & "'"), 0) <> 0 Then FnSearch = DLookup("Column2", "Sheet2", "Column1='" & Trim(Arr(i)) & " " & Trim(Arr(i + 1)) & " " & Trim(Arr(i + 2)) & "'") Exit For وعذرا للاطالة

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

في هذه الحالة نستعمل round يمكنك استعمال هذه المعادلة في الخلية C2 =ROUND(B2*50%,0) وهى لتقريب نسبة 50٪ من الخلية b2 مع عدم تعديل الخلية k2 بالتوفيق

اشكرك خي الغالي ولكن عندما يكون الرقم لدي 255.10 اجده بهذه الدالة يجبر الى 256 انا اريد اذا كان اقل من النصف لا يجبر .... و من النصف فما فوق يجبر للاعلى

اخي الكريم جزاك الله خيرا أستاذ محمد صالح للأسف انا عندي أوفيس ٢٠١٦ هل في معادلة لهذا الاصدار ؟

طيب اخي الكريم انت تقول غير اسم التقرير في الكود ..... وتريد ان معالج اختيار مكان الحفظ استخدم هذا الكود ...... DoCmd.OutputTo acOutputQuery, "rpt_Items_Dates_3", "ExcelWorkbook(*.xlsx)", "", False, "", , acExportQualityPrint

وعليكم السلام ورحمة الله وبركاته يمكنك استخدام office runtime سيقوم بتشغيل الاكسيس بدون امكانية التعديل على التصميم https://www.microsoft.com/en-us/download/details.aspx?id=50040 تحياتي

رائع أستاذ @Ali Mohamed Ali ولإثراء الموضوع يمكن جلب الجزء الأول بالمعادلة التالية المختصرة =LEFT(AD1,FIND("-",AD1)-1) بالتوفيق

وعليكم السلام-دائماً وأبداً لابد من تدعيم اى مشاركة بملف موضح فيه المطلوب بكل دقة...فيمكنك استخراج الرقم 2018 بالمعادلة التالية =LEFT(AD1,LEN(AD1)-FIND("-",AD1)) أما 2019 بالمعادلة التالية =RIGHT(AD1,LEN(AD1)-FIND("-",AD1))

تفضل أخي الكريم https://www.google.com/search?q=شرح%2Boffset%2Bexcel

جميعا بإذن الله

يمكنك استعمال هذا الكود Sub rng2jpg(Rng As Range) Dim Chrt As ChartObject Rng.CopyPicture xlScreen, xlPicture Set Chrt = ActiveSheet.ChartObjects.Add(Left:=0, Top:=0, Width:=Rng.Width, Height:=Rng.Height) Chrt.Activate With Chrt.Chart .Paste .Export Filename:=ThisWorkbook.Path & "\mas.jpg", Filtername:="JPG" End With oChrtO.Delete MsgBox "Done by mr-mas.com" End Sub ولاستدعائه Sub mas() rng2jpg Range("a1:f20") End sub وتم فصل الإجراءين لسهولة التعامل مع الكود في أكثر من شيت ويمكن الاستغناء عن الإجراء الثاني إذا أضفنا تحديد النطاق إلى الإجراء الأول كما في السطر الثالث ليصبح Sub rng2jpg() Dim rng As Range, Chrt As ChartObject Set Rng = Range("a1:f20") Rng.CopyPicture xlScreen, xlPicture Set Chrt = ActiveSheet.ChartObjects.Add(Left:=0, Top:=0, Width:=Rng.Width, Height:=Rng.Height) Chrt.Activate With Chrt.Chart .Paste .Export Filename:=ThisWorkbook.Path & "\mas.jpg", Filtername:="JPG" End With Chrt.Delete MsgBox "Done by mr-mas.com" End Sub بالتوفيق

View the full article

موعدنا اليوم مع شرح طريقة كيف تعرف أسعار العملات اليوم بدون مغادرة برنامجك في VBA اوفيس 2003 أو 2007 أو 2010 أو 2013 أو 2016 أو 2019 سواء برنامج اكسس أو اكسل أو وورد أو باوربوينت مع التعرف على أكواد عملات العالم وكذلك اسماء العملات باللغة العربية والانجليزية التعرف على نسخ النص الموجود في مربع النص إلى الحافظة والكثير من المفاجآت اكتشفها بنفسك ثالثا لمن يريد تحميل الملف الذي تم استخدامه في الشرح يمكنكم التعليق سواء هنا في المدونة أو في اليوتيوب وسيصلكم رابط الملف بإذن الله والآن مع فيديو الشرح ************** ولا تنسوا أحبابي الدعاء لغيركم بظهر الغيب حتى يقول لك الملك: آمين ولك مثلها إن شاء الله وتذكر لو بخل بها غيرك ما وصلت إليك فشارك المعلومة مع جميع أصدقائك في جميع مواقع التواصل الاجتماعي ============ القادم أفضل بإذن اللهView the full article

يوجد ملف الطلوب حساب ايام الجمع لكل شهر حسب كتابة التاريخ لكل سنة المصنف1.xlsx