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

واياك ... حياك الله

وعليكم السلام تفضل .... Kan_aa.accdb

جرب المرفق لعله ماتريد .... DATA144 - kanory.mdb

السلام عليكم ورحمة الله عمل طيب جعله الله فى ميزان حسناتك

تمت الاجابة على طلبك في الموضوع الاصل 🙂 جعفر

. قصدك هذه الازرار: . السبب ان هذه الازرار لا تتفاعل مع اعدادات النموذج ، لأن هذه ازرار البرنامج وليست ازرار النموذج 🙂 وطريقة إخفائهم تتم عن طريق مكتبات الوندوز: Private Const GWL_STYLE = (-16) Private Const WS_CAPTION = &HC00000 Private Const WS_MINIMIZEBOX = &H20000 Private Const WS_MAXIMIZEBOX = &H10000 Private Const WS_SYSMENU = &H80000 Private Const SWP_NOSIZE = &H1 Private Const SWP_NOMOVE = &H2 Private Const SWP_NOZORDER = &H4 Public Const SWP_FRAMECHANGED = &H20 Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" ( _ ByVal hwnd As Long, _ ByVal nIndex As Long) As Long Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" ( _ ByVal hwnd As Long, _ ByVal nIndex As Long, _ ByVal dwNewLong As Long) As Long Private Declare PtrSafe Function SetWindowPos Lib "user32" ( _ ByVal hwnd As Long, _ ByVal hWndInsertAfter As Long, _ ByVal X As Long, _ ByVal Y As Long, _ ByVal cx As Long, _ ByVal cy As Long, _ ByVal wFlags As Long) As Long ' ************************************************** ' Public Function AccessTitleBar(Show As Boolean) As Long ' ' Calling it AccessTitleBar(0) ' This will Hide Acces Title Bar ' it will fill the screen, without a Title Bar without Buttons, so you will have to give the use a way to quit ' Dim hwnd As Long Dim nIndex As Long Dim dwNewLong As Long Dim dwLong As Long Dim wFlags As Long hwnd = hWndAccessApp nIndex = GWL_STYLE wFlags = SWP_NOSIZE + SWP_NOZORDER + SWP_FRAMECHANGED + SWP_NOMOVE dwLong = GetWindowLong(hwnd, nIndex) If Show Then dwNewLong = (dwLong Or WS_CAPTION) Else dwNewLong = (dwLong And Not WS_CAPTION) End If Call SetWindowLong(hwnd, nIndex, dwNewLong) Call SetWindowPos(hwnd, 0&, 0&, 0&, 0&, 0&, wFlags) End Function Public Function AccessTitleBarButtons(Show As Boolean) As Long ' ' Calling it AccessTitleBarButtons(0) ' This will Hide the Buttons: MINIMIZE, AXIMIZE, Close buttons on the Access Title Bar ' to Hide MINIMIZE Button ONLY: Const FLAGS_COMBI = WS_MAXIMIZEBOX Or WS_SYSMENU ' to Show MINIMIZE Button ONLY: Const FLAGS_COMBI = WS_MINIMIZEBOX ' ' to Hide them all: Const FLAGS_COMBI = WS_MINIMIZEBOX Or WS_MAXIMIZEBOX Or WS_SYSMENU ' Dim hwnd As Long Dim nIndex As Long Dim dwNewLong As Long Dim dwLong As Long hwnd = hWndAccessApp nIndex = GWL_STYLE Const wFlags = SWP_NOSIZE + SWP_NOZORDER + SWP_FRAMECHANGED + SWP_NOMOVE Const FLAGS_COMBI = WS_MINIMIZEBOX Or WS_MAXIMIZEBOX Or WS_SYSMENU dwLong = GetWindowLong(hwnd, nIndex) If Show Then dwNewLong = (dwLong Or FLAGS_COMBI) Else dwNewLong = (dwLong And Not FLAGS_COMBI) End If Call SetWindowLong(hwnd, nIndex, dwNewLong) Call SetWindowPos(hwnd, 0&, 0&, 0&, 0&, 0&, wFlags) End Function . 1. اذا اردنا اخفاء الازرار ، فننادي دالة: AccessTitleBarButtons(0) 2. بينما اذا لا نريد الازرار ، ولا نريد تحريك البرنامج من شريط الادوات Toolbar ، فيجب اخفاء شريط الادوات (ويمكن استبداله في النموذج بمربع تسمية ، اذا لزم الامر) ، فننادي دالة: AccessTitleBar(0) المناداة تكون في ملف الماكرو AutoExec والذي يعمل تلقائيا لما يعمل البرنامج : . لتصبح الشاشة هكذا: جعفر example_semo.zip

حرب هذا الملف لا ضرورة لادراج اكثر من 700 صف لان المكرو الذي يعمل على صف واجد يستطيع العمل على الألوف منها يكفي ادراج نموذح بسيط لما تريد (50 صف كحد أقصى) كما اني لم أفهم ما هي الحاجة الى اليوزر فورم؟؟؟ Option Explicit Sub Get_data() Dim H As Worksheet Dim T As Worksheet Dim LrH%, LrT%, i%, Sd#, _ k%, Se#, My_val#, n% Dim Date1 As Date, Date2 As Date Dim M_date As Date, X_date As Date Dim Fr As Range, Wat As Range, Ro1%, Ro2% Dim x As Boolean, y As Boolean Set H = Sheets("Haraka") Set T = Sheets("Takrir") LrH = H.Cells(Rows.Count, 1).End(3).Row LrT = 20 T.Range("D5").Resize(LrT, 3).ClearContents Date1 = Application.Min(H.Range("C4:C" & LrH)) Date2 = Application.Max(H.Range("C4:C" & LrH)) If Not IsDate(T.Range("D2")) Or Not IsDate(T.Range("E2")) Then MsgBox "Please Type Dates in D2 and E2" Exit Sub End If M_date = T.Range("D2"): X_date = T.Range("E2") If Not IsDate(T.Range("D2")) Or Not IsDate(T.Range("E2")) Then MsgBox "Wrong Dates" Exit Sub End If T.Range("D2") = Application.Min(M_date, X_date) T.Range("E2") = Application.Max(M_date, X_date) M_date = T.Range("D2"): X_date = T.Range("E2") Set Wat = H.Range("A3:A" & LrH) For i = 5 To LrT Set Fr = Wat.Find(T.Range("B" & i), lookat:=1) If Fr Is Nothing Then GoTo Again Ro1 = Fr.Row: Ro2 = Ro1 Do x = H.Range("C" & Ro2) >= M_date y = H.Range("C" & Ro2) <= X_date If x And y Then Sd = Sd + Val(H.Range("D" & Ro2)) Se = Se + Val(H.Range("E" & Ro2)) n = n + 1 End If Set Fr = Wat.FindNext(Fr) Ro2 = Fr.Row If Ro2 = Ro1 Then Exit Do Loop T.Range("D" & i) = IIf(Sd = 0, "", Sd) T.Range("E" & i) = IIf(Se = 0, "", Se) My_val = Val(T.Range("C" & i)) + Val(T.Range("D" & i)) _ - Val(T.Range("E" & i)) T.Range("F" & i) = IIf(My_val = 0, "", My_val) T.Range("G" & i) = IIf(n = 0, "", n) Again: Sd = 0: Se = 0: n = 0 Next i End Sub T_Mansour.xlsm

واياكم اخي بالتوفيق

نموذج عما تريده Naser_Masry.xlsx

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

تفضل هذا التعديل DATA200026.mdb.zip

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

بعد اذن الاستاذ إبراهيم هذا الكود Option Explicit Sub My_Repport() Dim Mh As Range, Single_Cel As Range Dim Y%, M%, i%, x% Dim My_Months(), Arr_Year() x = 6 Takrir.Range("A5").CurrentRegion.Offset(1).ClearContents Arr_Year = Array(2020, 2021, 2022, 2023, 2024, 2025) My_Months = Array("يناير", "فبراير", "مارس", "أبريل", "مايو", "يونيو", _ "يوليو", "أغسطس", "سبتمبر", "أكتوبر", "نوفمبر", "ديسمبر") If IsError(Application.Match( _ Takrir.Range("B3"), Arr_Year, 0)) Then Exit Sub If IsError(Application.Match( _ Takrir.Range("A3"), My_Months, 0)) Then Exit Sub Set Mh = Mahmoud.Range("A5").CurrentRegion.Columns(2) Y = Takrir.Range("B3") M = Application.Match(Takrir.Range("A3"), My_Months, 0) For Each Single_Cel In Mh.Cells If IsDate(Single_Cel) And Month(Single_Cel) = M _ And Year(Single_Cel) = Y Then Takrir.Range("A" & x).Resize(, 5).Value = _ Single_Cel.Offset(, -1).Resize(, 5).Value x = x + 1 End If Next Single_Cel End Sub الملف مرفق Naser_data.xlsm

هذه ابسط طريقة .... طباعة.accdb

السلام عليكم ورحمة الله اليك الملف بعد اضافة بعض البيانات لعام 2022 للتجربة Sub GteData() Dim ws As Worksheet, Sh As Worksheet Dim Arr(), Temp() Dim y As Integer, m As Integer Dim yy As Integer, mm As Integer Dim i As Long, j As Long, p As Long Set ws = Sheets("تقرير السنين") Set Sh = Sheets("محمود") ws.Range("A9:E" & ws.Range("B" & Rows.Count).End(3).Row).ClearContents m = Month("01/" & ws.Range("A3").Value) y = ws.Range("B3").Value Arr = Sh.Range("A9:E" & Sh.Range("B" & Rows.Count).End(3).Row).Value ReDim Temp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2)) For i = 1 To UBound(Arr, 1) yy = Year(Arr(i, 2)) mm = Month(Arr(i, 2)) If yy = y And mm = m Then p = p + 1 For j = 1 To UBound(Arr, 2) Temp(p, j) = Arr(i, j) Next End If Next If p > 0 Then ws.Range("A9").Resize(p, UBound(Temp, 2)).Value = Temp End Sub Naser.xlsm

Try This File Jalal.xlsx

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

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