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

السلام عليكم ورحمة الله وبركاته هذه محاولة في الملف المرفق إن كنت قد وُفقت في فهم المطلوب... جرد المخزن_1.xlsx

السلام عليكم ورحمة الله وبركاته ، أخواني وأساتذتي ومعلمينا ( دون استثناء ) كنت قد بحثت في المنتدى 🔍 (هنا) عن برامج لعرض مواقيت الصلاة ، وقد وجدت الكثير من المواضيع الجميلة والأفكار النيرة في المنتدى لأساتذة وأخوة بذلوا جهداً لا يوصف في مشاركاتهم بهذا الموضوع ، وإلى حد ما أكثرهم قرباً لضبط الأوقات كانت هذه المشاركة . اليوم الفكرة مختلفة قليلاً في هذا المشروع المتواضع والذي لا يحتوي تعقيدات يصعب قراءتها أو التعامل معها في الأكواد . حيث اعتمدت وتوجهت إلى البساطة من حيث عند النقل والدمج ( إلى / في ) أي مشروع . الآن شرح بسيط لبعض تفاصيل المشروع التي سيتم الإعتماد عليها :- سي سيتم الإعتماد على خطوط الطول والعرض بعد إجراء بعض التعديلات على طريقة احتساب الأوقات . وقد تمت المقارنة مع موقع ( مواقيت الصلاة ) للوصول إلى أقل فارق - إن وُجِد - في المواقيت . سيتم الإعتماد على تقويم أم القرى في أحدى مشاركات أستاذنا @ابوخليل . سيتم اعتماد إظهار الوقت المتبقي لكل موعد صلاة في الشاشة الرئيسية أو المصغرة ( ستضاف لاحقاً ) . سيتم منح الحرية للمستخدم بنوع التذكير لوقت الصلاة ( إشعار برسالة تنبيه داخل البرنامج ، إشعار فوق شريط Taskbar ) . سيتم أيضاً منح الحرية للمستخدم باختيار صوت التنبيه ( أذان كامل ، تكبير ، .... إلخ ) . المزيد من الأمور ستأتي لاحقاً تباعاً في تطويرات وتحديثات جديدة إن شاء الله . صورة لواجهة البرنامج حالياً ، والذي أسميته في الوقت الحالي " صلوات " 🤗 ، ما لم يتم اختيار اسم آخر

cleantabeles.rar تفضل اخي كان هناك خطأين اعتذر عنهم لاني جمعت لك الكود بسرعة وكنت اختبر من زر وليس موديول فقط تستبدل me باسم النموذج هكذا forms!cleaner كما ان هناك متغير معلن اكثر من مرة اوقفته الان الكود يعمل لكننا استبدلنا احد الحروف الخمسة بكلمة عبد لامكانك اضافة حلقة جديدة للحرف او اى شئ اخر cleantabeles.rar

تحياتي... ألق نظرة على الملف المرفق لعل فيه ما تريد... حساب النقاط.xlsx

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

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

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

😉 اقصد هذا السطر يا صديقي hMenu = GetSystemMenu(hwnd, 1&)

عمل جيد أخي @طير البحر ودعماً لمحاولتك ، هذا الجزء الخاص بزر RestoreDown Sub DisableRestoreDownButton() Dim hwnd As Long Dim M As Long hwnd = Application.hWndAccessApp M = GetWindowLong(hwnd, GWL_STYLE) M = M And Not WS_MAXIMIZEBOX Call SetWindowLong(hwnd, GWL_STYLE, M) End Sub Sub RestoreRestoreDownButton() Dim hwnd As Long Dim M As Long hwnd = Application.hWndAccessApp M = GetWindowLong(hwnd, GWL_STYLE) M = M Or WS_MAXIMIZEBOX Call SetWindowLong(hwnd, GWL_STYLE, M) End Sub بعد إذنك لاحظت وجود خطأ في الجزء المسؤول عن أعادة تفعيل زر اغلاق الآكسيس :- أرجو التعديل من هذا الجزء Sub enableCloseButtonfunction() Dim hwnd As Long Const SC_CLOSE = &HF060 Const MF_BYCOMMAND = &H0 hwnd = Application.hWndAccessApp Dim hMenu As Long hMenu = GetSystemMenu(hwnd, 0&) If hMenu Then ' DeleteMenu hMenu, SC_CLOSE, MF_BYCOMMAND 'Disable the Close button ááÇáÛÇÁ DrawMenuBar (hwnd) 'Repaint the MenuBar ááÊÔÛíá End If End Sub إلى هذا الجزء Sub enableCloseButtonfunction() Dim hwnd As Long Const SC_CLOSE = &HF060 Const MF_BYCOMMAND = &H0 hwnd = Application.hWndAccessApp Dim hMenu As Long hMenu = GetSystemMenu(hwnd, 1&) If hMenu Then DrawMenuBar (hwnd) End If End Sub

هذا موضوع اخر اخي كمال يرجي فتح موضوع اخر بالطلب الجديد

Do it yourself Press Alt + F11 >> Insert Module >> Paste the code

سنجرى عملية استبدال وساضيفها للكود

Try this code Sub Test() Dim ws As Worksheet, fso As Object, sPath As String, lr As Long, iRow As Long Set ws = ActiveSheet Set fso = CreateObject("Scripting.FileSystemObject") lr = ws.Cells(Rows.Count, 1).End(xlUp).Row ws.Columns(1).Interior.Color = xlNone For iRow = 2 To lr sPath = ThisWorkbook.Path & "\" & ws.Cells(iRow, 1).Value If fso.FolderExists(sPath) Then ws.Cells(iRow, 1).Interior.Color = vbGreen End If Next iRow End Sub

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

الكود السابق اخي وباختصار يقوم بانشاء جدول مؤقت باسم year_table في كل مرة يجلب البيانات من استعلام معين حسب جدول السنة ( الاولى - الثانية - الثالثة ) عن طريق select case ثم يقوم بتصدير البيانات لملف الاكسل ... ثم حذف الجدول المؤقت هنا مثال ممتاز لاخونا الاستاذ @ابوخليل مثلا عند no ابحث في مثال اخونا تجدها من ضمن الكلمات المحجوزة الحقول المحسوبة اعني بها في الجدول .... حاول تعملها في الاستعلام او التقرير او النماذج .... والله اعلم

اخي الكريم من وجهة نظري الشخصية ::: لديك بعض الأخطاء منها ::::: * استخدام الكلمات او العبارات المحجوزة للأكسس * تكرار بعض مسميات الحقول في الاستعلامات * الحقول المحسوبة * ايضا ادخال المواد التدريسية لماذا لم تتم بشكل سجلات بدلا من ادخالها افقيا على كل حال ( لو كنت مصر على طريقتك تفضل بعض الحل للمشكلة ) اعمل زر وضع فيه هذه الشيفره Dim sXlsFile As String sXlsFile = CurrentProject.Path & "\ww1.xlsx" DoCmd.SetWarnings False If Not IsNull(Forms!w_moka_mid9!MM) Then Select Case Forms!w_moka_mid9!MM Case Is = "الاولى" DoCmd.RunSQL " SELECT [year-table1].[full-name], [year-table1].[natio-no], [year-table1].exper, [year-table1].cerf, [EXPR2] & "", "" & [EXPR3] & "", "" & [EXPR4] AS EXPR6 INTO year_table " & _ " FROM [year-table1] " & _ " WHERE ((Not ([year-table1].EXPR5) Is Null));" Case Is = "الثانية" DoCmd.RunSQL " SELECT [year-table2].[full-name], [year-table2].[natio-no], [year-table2].exper, [year-table2].cerf, [EXPR2] & "", "" & [EXPR3] & "", "" & [EXPR4] AS EXPR6 INTO year_table " & _ " FROM [year-table2] " & _ " WHERE ((Not ([year-table2].EXPR5) Is Null));" Case Is = "الثالثة" DoCmd.RunSQL " SELECT [year-table3].[full-name], [year-table3].[natio-no], [year-table3].exper, [year-table3].cerf, [EXPR2] & "", "" & [EXPR3] & "", "" & [EXPR4] AS EXPR6 INTO year_table " & _ " FROM [year-table3] " & _ " WHERE ((Not ([year-table3].EXPR5) Is Null));" End Select Call Export_Excel_officena_by_aba_judy(sXlsFile, "SELECT * FROM year_table", 6) DoCmd.DeleteObject acTable, "year_table" Else MsgBox "اختر جداول السنة المطلوب عرض تقريرها", vbCritical, "انتبــــــه" End If DoCmd.SetWarnings True

بارك الله فيك وزادك الله من فضله

اخي عاصم ممكن التواصل مع حضرتك لو سمحت

عدل DestPath = ThisWorkbook.Path & "\" & Sh.Range("e11") & ".pdf" الى DestPath = "\\10.20.30.3\homedir\a.ghanem\كشف العمليات اليومية\" & Sh.Range("e11") & ".pdf"

السلام عليكم ورحمة الله تم عمل المطلوب مع بعض الإضافات المستحسنة (تحضير قائمة منسدلة للصفوف بالتسمية Liste من خلال معادلات في العمودين Z و AA من شيت ... ) new2.xlsx

استكمالاً لما سبق 👆 :- بطريقة بسيطة سيتم الاعتماد على حساب الجيب العكسي للزوايا باستخدام دالة الرمز الجيبي العكسي (Arcsine)، والتي يُرمز لها بـ ASin . تُستخدم الدالة ASin في الرياضيات لحساب الزاوية التي تمثلها الجيب العكسي لنسبة محددة من الجانب المقابل لزاوية مثلث، عندما يُعرف طول الضلع المقابل لهذه الزاوية . ويتمثل ذلك في المعادلة الرياضية . صورة تعبيرية وبناءً على هذه المعادلة سيتم احتساب أوقات الصلاة باستخدام معادلات فلكية و جيوغرافية ، ومن ثم سنعيد القيمة الراجعة بتنسيق معين بشكل وقت . حسب المديول التالي ، والذي يعتبر عامود المشروع وقوامه وأساسه :- Option Compare Database Const PI As Double = 3.14159265358979 Function ASin(Value As Double) As Double If Abs(Value) <> 1 Then ASin = Atn(Value / Sqr(1 - Value * Value)) Else ASin = 1.5707963267949 * Sgn(Value) End If End Function Public Function ACos(ByVal nValue As Double, Optional fRadians As Boolean = True) As Double ACos = -Atn(nValue / Sqr(1 - nValue * nValue)) + PI / 2 If fRadians = False Then ACos = ACos * (PI / 180) End Function Function gettimes(lag As Double, lat As Double, tzon As Double, stime As String, method As Integer, Optional dylt As Integer = 0, Optional strdate As Date) As Date ' تعريف المتغيرات المستخدمة Dim D, L, m, lambda, alpha, noon, alt, UTNoon, localNoon, st, Dec, ar, obl As Double ' حساب تاريخ اليوم D = (367 * Year(strdate)) - Int(((Year(strdate) + Int((Month(strdate) + 9) / 12)) * 7) / 4) + Int(275 * Month(strdate) / 9) + Day(strdate) - 730531.5 ' حساب زاوية الشمس والشروق والغروب L = 280.461 + 0.9856474 * D L = L - (360 * Int(L / 360)) m = 357.528 + 0.9856003 * D m = m - (360 * Int(m / 360)) lambda = L + 1.915 * Sin(m * PI / 180) + 0.02 * Sin(2 * m * PI / 180) obl = 23.439 - 0.0000004 * D ' حساب موضع الشمس وزاوية الشروق والغروب alpha = Atn(Cos(obl * PI / 180) * Tan(lambda * PI / 180)) * 180 / PI alpha = alpha - (360 * Int(alpha / 360)) alpha = alpha + 90 * (Fix(lambda / 90) - Fix(alpha / 90)) st = 100.46 + 0.985647352 * D st = st - (360 * Int(st / 360)) Dec = ASin(Sin(obl * PI / 180) * Sin(lambda * PI / 180)) * 180 / PI noon = alpha - st noon = noon - (360 * Int(noon / 360)) UTNoon = noon - lag localNoon = (UTNoon / 15) + tzon + dylt ' حساب أوقات الصلاة Select Case stime Case Is = "Fajr" ' حساب وقت الفجر alt = DLookup("FajrDegree", "PrayerCalculation", "MethodType=" & method & "") ar = ACos((Sin(alt * PI / 180) - Sin(Dec * PI / 180) * Sin(lat * PI / 180)) / (Cos(Dec * PI / 180) * Cos(lat * PI / 180))) * 180 / PI fajr = localNoon - ar / 15 gettimes = Format(fajr / 24, "hh:nn:ss") Case Is = "Shrok" ' حساب وقت الشروق alt = -1 ar = ACos((Sin(alt * PI / 180) - Sin(Dec * PI / 180) * Sin(lat * PI / 180)) / (Cos(Dec * PI / 180) * Cos(lat * PI / 180))) * 180 / PI shrouk = localNoon - ar / 15 gettimes = Format(shrouk / 24, "hh:nn:ss") Case Is = "Zohr" ' حساب وقت الظهر gettimes = Format(localNoon / 24, "hh:nn:ss") Case Is = "Asr1" ' حساب وقت العصر (الطريقة الأولى) alt = 90 - Atn(1 + Tan(Abs(lat - Dec) * PI / 180)) * 180 / PI ar = ACos((Sin(alt * PI / 180) - Sin(Dec * PI / 180) * Sin(lat * PI / 180)) / (Cos(Dec * PI / 180) * Cos(lat * PI / 180))) * 180 / PI asr = localNoon + ar / 15 gettimes = Format(asr / 24, "hh:nn:ss") Case Is = "Asr2" ' حساب وقت العصر (الطريقة الثانية) alt = 90 - Atn(2 + Tan(Abs(lat - Dec) * PI / 180)) * 180 / PI ar = ACos((Sin(alt * PI / 180) - Sin(Dec * PI / 180) * Sin(lat * PI / 180)) / (Cos(Dec * PI / 180) * Cos(lat * PI / 180))) * 180 / PI asr = localNoon + ar / 15 gettimes = Format(asr / 24, "hh:nn:ss") Case Is = "Maghrib" ' حساب وقت المغرب alt = -1 ar = ACos((Sin(alt * PI / 180) - Sin(Dec * PI / 180) * Sin(lat * PI / 180)) / (Cos(Dec * PI / 180) * Cos(lat * PI / 180))) * 180 / PI maghrib = localNoon + ar / 15 gettimes = Format(maghrib / 24, "hh:nn:ss") Case Is = "Eshaa" ' حساب وقت العشاء If method = 4 Then alt = -1 ar = ACos((Sin(alt * PI / 180) - Sin(Dec * PI / 180) * Sin(lat * PI / 180)) / (Cos(Dec * PI / 180) * Cos(lat * PI / 180))) * 180 / PI maghrib = localNoon + ar / 15 If Month(CStr(Date)) = 9 Then gettimes = Format((maghrib + 2) / 24, "hh:nn:ss") Else gettimes = Format((maghrib + 1.5) / 24, "hh:nn:ss") End If Else alt = DLookup("IshaDegree", "PrayerCalculation", "MethodType=" & method & "") ar = ACos((Sin(alt * PI / 180) - Sin(Dec * PI / 180) * Sin(lat * PI / 180)) / (Cos(Dec * PI / 180) * Cos(lat * PI / 180))) * 180 / PI eshaa = localNoon + ar / 15 gettimes = Format(eshaa / 24, "hh:nn:ss") End If End Select End Function يتبع ... 👈

مرحبا بك استاذ @jo_2010 بالنسبة للمطلب الثاني ليست لدي فكرة عنه LAB_GOOD.rar

فكره حلوه ،، شكرا على الهديه الجميله

تسلم على الهدية القيمة

لا اعتقد ذلك .

السلام عليكم ورحمة الله تعالى وبركاته بعد ادن الاستاد @عبدالله بشير عبدالله اليك حل اخر ربما يناسبك هدا الكود لفلترة البيانات بين التواريخ ونسخها لورقة مخفية على نفس المصنف باسم printing Sub FilterByDate() Dim WS As Worksheet: Set WS = Worksheets("Sheet1") Dim desWS As Worksheet: Set desWS = Sheets("الانشطة") Dim f As Worksheet: Set f = printing Dim MinDate As Date, MaxDate As Date, lr As Long Dim a As Range, r As Long MinDate = desWS.[d2]: MaxDate = desWS.[f2] Application.ScreenUpdating = False If MinDate > MaxDate Then: Exit Sub If Len(desWS.[f2]) > 0 And IsDate(desWS.[d2]) Then If WS.AutoFilterMode Then WS.AutoFilterMode = False With WS.Range("A7:K7") .AutoFilter 3, ">=" & CLng(MinDate), 1, "<=" & CLng(MaxDate) lr = WS.Columns("A:K").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row Set rng = WS.Range("A" & lr & ":k" & lr).SpecialCells(xlCellTypeVisible) If WorksheetFunction.Subtotal(3, WS.Columns(3)) > 1 Then desWS.Range("A5:K" & Rows.Count).Clear With rng Cpt = Split("A,B,C,D,E,F,G,H,I,J,k", ",") Col = Split("A,B,C,D,E,F,G,H,I,J,k", ",") For i = LBound(Cpt) To UBound(Cpt) WS.Range(Cpt(i) & "8:" & Cpt(i) & lr).Copy desWS.Range(Col(i) & "5") Next i End With lige = desWS.Range("A:J").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row Cpt1 = "=IF(c5="""","""",IF(c5=""Name"",""Count"",N(b4)+1))" Cpt2 = "=IF(ISBLANK(b5),"""",SUBTOTAL(3,B$5:B5))" With desWS .Range("B5:B" & lige).Formula = Cpt1: .Range("A5:A" & lige).Formula = Cpt2 .Range("A5:B" & lige).Value = .Range("A5:B" & lige).Value End With End If .AutoFilter End With f.Range("A2:K" & f.Rows.Count).Clear Set a = desWS.Range("A4", desWS.Range("A" & desWS.Rows.Count).End(xlUp)) For r = 1 To 11 Set a = Union(a, Intersect(a.EntireRow, Columns(r))) Next r a.Copy Destination:=f.Range("a2") End If Application.ScreenUpdating = True End Sub لحفظ الملف بصيغة PDF Sub Save_folder_PDF() Dim sFile As String, sPath As String, fPath As String Dim sMsg As String Dim desWS As Worksheet: Set desWS = Sheets("الانشطة") Dim f As Worksheet: Set f = printing sFile = "تقرير النشاط" folderName = "ملفات PDF" Application.ScreenUpdating = False Msg = MsgBox("؟" & " " & "PDF " & ":" & " تصدير التقرير بصيغة", vbYesNo, f.Name) If Msg <> vbYes Then Exit Sub f.Visible = xlSheetVisible With ActiveWorkbook sPath = .path & Application.PathSeparator & folderName & Application.PathSeparator On Error Resume Next If Len(Dir(sPath, vbDirectory)) = 0 Then End If MkDir sPath f.VPageBreaks(1).DragOff Direction:=xlToRight, RegionIndex:=1 f.ExportAsFixedFormat Type:=xlTypePDF, _ FileName:=sPath & Application.PathSeparator & sFile & ".pdf", _ Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False f.Visible = xlSheetVeryHidden End With sMsg = "PDF" & " " & "تم حفظ التقرير بنجاح في مجلد " & "ملفات" MsgBox sMsg, vbExclamation, " من تاريخ: " & " " & desWS.[d2] & " " & "إلى تاريخ:" & " " & desWS.[f2] Application.ScreenUpdating = True End Sub لحفظ التقرير في ملف مستقل Sub Save_folder_Excel() Dim WS As Worksheet: Set WS = printing Dim desWS As Worksheet: Set desWS = Sheets("الانشطة") Dim path As String, folderName As String, sMsg As String Dim newWb As Workbook, Fname As String path = ThisWorkbook.path & "\" On Error Resume Next Msg = MsgBox("؟" & " " & "Excel " & ":" & " تصدير التقرير بصيغة", vbYesNo, WS.Name) If Msg <> vbYes Then Exit Sub With Application .ScreenUpdating = False .DisplayAlerts = False WS.Visible = xlSheetVisible folderName = "ملفات Excel" MkDir path & folderName Fname = folderName & "\" & WS.Name WS.Copy Set newWb = ActiveWorkbook newWb.SaveAs FileName:=path & Fname & ".xlsx", FileFormat:=51 newWb.Close WS.Visible = xlSheetVeryHidden .DisplayAlerts = True .ScreenUpdating = True End With On Error GoTo 0 sMsg = "Excel" & " " & "تم حفظ التقرير بنجاح في مجلد " & "ملفات" MsgBox sMsg, vbExclamation, " من تاريخ: " & " " & desWS.[d2] & " " & "إلى تاريخ:" & " " & desWS.[f2] End Sub فلترة وحفظ PDF +EXCEL.xlsm

تم تغيير الكود(انسخه الى موديل جديد و عين له زراً للتنفيذ) Option Explicit Option Base 1 Sub Salim_Extract() Dim Src_Sh As Worksheet Dim Trg_Sh As Worksheet Dim xx, lr, m, My_Row As Integer Dim ArrJ(), ArrG() Dim t As Long Application.ScreenUpdating = False My_Row = 4 Set Trg_Sh = Sheets("الديون") Trg_Sh.Range("e4").Resize(10000, 3).Clear For m = 3 To Sheets.Count - 2 t = 1 Set Src_Sh = Sheets(m) With Src_Sh .Select On Error GoTo 1 On Error Resume Next lr = .Cells(Rows.Count, "j").End(3).Row For xx = 4 To lr If .Cells(xx, "j") > 0 And Cells(xx, "j") <> "" Then ReDim Preserve ArrJ(t) ReDim Preserve ArrG(t) ArrJ(t) = .Cells(xx, "j").Value ArrG(t) = .Cells(xx, "G").Value: t = t + 1 End If Next End With Trg_Sh.Range("g" & My_Row).Resize(UBound(ArrJ)) = Application.Transpose(ArrJ) Trg_Sh.Range("f" & My_Row).Resize(UBound(ArrG)) = Application.Transpose(ArrG) Trg_Sh.Range("e" & My_Row).Resize(UBound(ArrG)) = Sheets(m).Cells(1, 2) Trg_Sh.Range("f" & My_Row).Resize(UBound(ArrG)).NumberFormat = "m/d/yyyy" My_Row = My_Row + t Trg_Sh.Range("e" & My_Row - 1).Resize(, 3).Interior.ColorIndex = 6 1: Erase ArrJ: Erase ArrG Next Application.ScreenUpdating = True Trg_Sh.Activate: Range("e3").Select End Sub الملف المرفق اصنافform salim 1.rar