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

اللهم آمين الامر لله حبيبى الغالى متحرمش منك اباجودى بالتوفيق اخى العزيز

حزانا الله واياكم وكل أساتذتنا خير الجزاء اتفضل تحت امرك AutoCentre.mdb

الشيء الذي أغضبني منك هو هذا الموضوع انا لا اقوم بهدر وقتي في عمل برامج خارجية مساعدة للأكسس وقمت بعمل البرنامج لك واستغرق مني 3 ساعات متواصلة لأتفاجئ بأنك لم ترى الموضوع حتى ولم تقل لي هل نجحت الطريقة ام لا اعتذارك مقبول اخي الكريم

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

وعليكم السلام-جرب هذا الكود Private Sub Worksheet_Activate() With Cells.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .Color = RGB(0, 192, 192) .TintAndShade = 0 .PatternTintAndShade = 0 End With End Sub Book2.xlsm

تفضل 🙂 من استعلام المجاميع qry_rpt ننادي الدالة Concatenate_test_items التي تقوم بإرسال قيمة code ، ومنها تجمع النتائج test في سطر واحد . والنتيجة . ونستعمل هذا الاستعلام كمصدر بيانات التقرير. وهذه هي دالة Concatenate_test_items : Public Function Concatenate_test_items(C As String) As String Dim rst As DAO.Recordset Dim myWhere As String 'do the Where Criteria in an easy way, item by item myWhere = myWhere & "[code]='" & C & "'" 'set the Data source Set rst = CurrentDb.OpenRecordset("Select [test] From [Table1] Where " & myWhere) 'Loop through the Records Do Until rst.EOF 'Concatenate the items Concatenate_test_items = Concatenate_test_items & ", " & rst!test 'move to the next Record rst.MoveNext Loop 'Remove the initial ", ", thats why we start from the 3rd letter Concatenate_test_items = Mid(Concatenate_test_items, 3) 'clean up memory rst.Close: Set rst = Nothing End Function جعفر ملاحظة: لأني لا استعمل ActiveX الباركود ، فقد قمت بحذفه من الكود ، فيجب ان تختاره مرة اخرى 1377.test.accdb.zip

تجميع و دمج عده ملفات عمل اكسيل في ملف عمل واحد Acc: Mohamed ElSayed 24 مارس، 2020 اضف تعليق 1,217 زيارة دمج عده ملفات عمل اكسيل في ملف عمل واحد كثيرا من الاحيان نحتاج في اعمالنا اليوميه الي تجميع و دمج عده ملفات عمل اكسيل في ملف عمل لنتعامل مع ملف واحد بدلا من التعامل مع عده ملفات و في هذا المقال نستعرض طريقه عمل ذلك بضغطه زر عن طريق كود برمجي مهما كان عدد شيتات العمل الذي نحتاج الي اضافته تجميع و دمج عده ملفات عمل اكسيل في ملف عمل واحد في البدايه دعنا نتعرف علي طريقه عمل هذا الملف ثم نستعرض فكره عمل هذا الكود كي نتمكن من تطوير هذا الكود في اعمالنا فالاهم من مجرد تطبيق اي كود هو فهمه كي نستطيع التعامل مع هذا الكود خطوات العمل دعنا نبدا بنسخ الكود المرفق و فتح ملف الاكسيل الذي نريد اضافه اليه كل الشيتات الاخري ثم اضغط Alt + F11 او اضغط ضغطه بزر الماوس الايمن علي اسم الشيت ثم اختر view code ليفتح محرر الاكواد ثم اختر من قائمه insert اختر module ثم قم بلصق الكود بعد ذلك قم بالحفظ و اغلق محرر الاكواد ثم انتقل الي الاكسيل و قم باختيرا save as من خلال القائمه file و غير صيغه الملف file type الي اي صيغه تقبل الكود و ليكن الصيغه xlsm الصيغه excel Macro-Enabled Workbook هي صيغه تتيح حفظ الاكواد و الوحدات النمطيه و النماذج داخل شيت العمل و تاخذ الامتداد .Xlsm بعد ذلك قم بنسخ هذا الملف داخل مجلد فارغ و قم بعمل مجلد اخر داخل هذا المجلد الفارغ و قم باعده تسميه هذا الملف الي اسم test ثم قم بوضع كل الملفات المراد دمجها الي مجلد test الجديد ثم انتقل الي ملف العمل الموجود به الكود و افتحه اضغط علي macro من خلال القائمه view اختر CollectWorkbooks اسم الماكرو الذي قمنا باضافته عن طريق الكود بمجرد عمل هذا الكود ينتقل كافه شيتات العمل من المجلد test الي الشيت المفتوح بنفس الترتيب خلال ثواني Option Explicit ()Sub CollectWorkbooks 'تعريف متغير من النوع النصي و اعطيناه اسم '( path) Dim Path As String 'تعريف متغير من النوع النصي و اعطيناه اسم '(Filename) Dim Filename As String 'تعريف متغير من النوع ورقه عمل و اعطيناه اسم ' (SH) Dim SH As Worksheet ' تعريف المتغير لترتيب اوراق العمل بالترتيب الصحيح و قمنا بافتراض قيمه اسميه له 'x Dim X As Long 'افترضنا قيمه افتراضيه للمتغير x بقيمه 1 X = 1 'تعين المتغير ليحدد مسار الملفات المراد دمجها بجوار مسار الملف الاساسي داخل مخلد test كاسم افتراضي Path = ThisWorkbook.Path & "\Test\" 'تعين المصنف ليساوي اسم كل مصنف داخل ملف العمل و مسار ملف العمل بصيغه ملف اكسيل ماكرو كضيغه افتراضيه يمكنها حفظ كود العمل Filename = Dir(Path & "*.xlsm") 'الغاء خاصيه اهتتزاز الشاشه Application.ScreenUpdating = False 'الغاء خاصيه الرسائل التنبهيه Application.DisplayAlerts = False 'حلقه تكراريه لحذف ورقه ما عدا ورقه المسار For Each SH In ThisWorkbook.Sheets If SH.Name <> "Collector" Then SH.Delete Next SH 'حلقه تكراريه للمصنفات الموجوده في المسار المحدد الي ان يجد اي مصنف في هذا المسار Do While Filename <> "" 'فتح المصنف Workbooks.Open Filename:=Path & Filename, ReadOnly:=True 'حلقه تكراريه لكل اوراق العمل داخل المصنف النشط For Each SH In ActiveWorkbook.Sheets 'نسخ ورقه العمل و لصقها بنهايه فهرس اوراق العمل SH.Copy After:=ThisWorkbook.Sheets(X) 'زياده قيمه المتغير بمقدار 1 X = X + 1 'الانتقال لورقه العمل التاليه Next SH 'اغلاق المصنف Workbooks(Filename).Close 'اعاده ضبط المتغير Filename = Dir() Loop 'تنشيط او تحديد ورقه العمل الاولي Sheets("Collector").Activate 'تفعيل خاصيه التنبيه بالرسائل Application.DisplayAlerts = True 'تفعيل خاصيه اهتزاز الشاشه Application.ScreenUpdating = True End Sub حيث ان هذا الكود يقوم بعمل حلقه تكراريه علي اسماء الشيتات داخل المجلد test و البدا باول شيت ثم اعاده عمل حلقه تكراريه اخري جديده علي اسماء الشيتات الموجوده في هذا الشيت لنقلها بالترتيب و بعد الانهاء يقوم باغلاق ملف الاكسيل الاول و الانتقال الي الحلقه التكراريه الاولي لياخذ الملف التالي و يعود و يكرر نفس الحلقه التكراريه حتي ينتهي من كل ملفات الاكسيل داخل المجلد test و بعد الانتهاء تقف الحلقه التكراريه و يقف الكود تم وضع شرح للكود بكافه تفاصيله يمكنك مشاهده داله حساب ضريبه كسب العمل- داله مبرمجه في الاكسيل يمكنك مشاهده تحويل pdf الي ورد او اكسيل بدون برامج يمكنك مشاهده الطباعه في الاكسيل يمكنك مشاهده حمايه البيانات في الاكسيل قد يعجبك ايضا تصميم شيت اليوميه الامريكيه قد يعجبك ايضا شرح داله البحث الداله vlookup بالامثله و التطبيقات العمليه المصدر موقع المحاسب العربي https://acc-arab.com/2020/03/blog-post_24-2.html

السلام عليكم، أحياناً تواجهنا مشكلة في الأكسس وهي تحول الارقام الى العربية خصوصاً اذا كان بجانب الرقم حروف عربية لذلك دعونا نختصر الوقت على العميل ونقوم بتعديل تنسيقات التاريخ والارقام..الخ برمجياً بدون الطلب من العميل تعديلها يدوياً اقدم لكم فنكشن للتعديل، يمكنكم التعديل والإضافة بحسب ماتجدوه مناسباً. Public Sub EditControlPanelInternational() 'Define a key registry path Dim strComputer Dim objRegistry Dim strKeyPath Dim strValueName Dim getValue Dim regKeyPath Dim strLocaleName, strCountry, strshortDateValue, strlongDateValue, strshortTimeValue, strlongTimeValue, strfirstDayOfWeekValue Const HKEY_CURRENT_USER = &H80000001 strComputer = "." Set objRegistry = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strComputer & "\root\default:StdRegProv") regKeyPath = "Control Panel\International" strLocaleName = "en-US" strCountry = "United States" strshortDateValue = "yyyy-MM-dd" strlongDateValue = "dddd, MMMM d, yyyy" strshortTimeValue = "h:mm tt" strlongTimeValue = "h:mm:ss tt" strfirstDayOfWeekValue = "6" srtnativedigits = "0123456789" objRegistry.SetStringValue HKEY_CURRENT_USER, regKeyPath, "LocaleName", strLocaleName objRegistry.SetStringValue HKEY_CURRENT_USER, regKeyPath, "sCountry", strCountry objRegistry.SetStringValue HKEY_CURRENT_USER, regKeyPath, "sShortDate", strshortDateValue objRegistry.SetStringValue HKEY_CURRENT_USER, regKeyPath, "sLongDate", strlongDateValue objRegistry.SetStringValue HKEY_CURRENT_USER, regKeyPath, "sShortTime", strshortTimeValue objRegistry.SetStringValue HKEY_CURRENT_USER, regKeyPath, "sTimeFormat", strlongTimeValue objRegistry.SetStringValue HKEY_CURRENT_USER, regKeyPath, "iFirstDayOfWeek", strfirstDayOfWeekValue objRegistry.SetStringValue HKEY_CURRENT_USER, regKeyPath, "sNativeDigits", srtnativedigits Debug.Print "Successfully changed system regional settings." End Sub للأمانة الفنكشن من كتابة saf لذلك انا قمت بإضافة السطر srtnativedigits = "0123456789" objRegistry.SetStringValue HKEY_CURRENT_USER, regKeyPath, "sNativeDigits", srtnativedigits لتغيير تنسيق الأرقام من عربي إلى انجليزي ومن ثم قمت بنقله لكم.

ممكن مرفق

ضع الكود الاتى فى مديول Private Type RECT X1 As Long Y1 As Long X2 As Long Y2 As Long End Type #If VBA7 Then Private Declare PtrSafe Function GetDesktopWindow Lib "user32" () As LongPtr Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hWnd As LongPtr, lpRect As RECT) As Long Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hWnd As LongPtr) As LongPtr Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hWnd As LongPtr, ByVal hDC As LongPtr) As Long Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As LongPtr, ByVal nIndex As Long) As Long #Else Private Declare Function GetDesktopWindow Lib "user32" () As Long Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, Rectangle As RECT) As Boolean Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long #End If Private Const WU_LOGPIXELSX = 88 Private Const WU_LOGPIXELSY = 90 Sub CenterForm(f As Form) Dim formWidth As Long, formHeight As Long Dim MaxWidth As Long, maxHeight As Long Dim ScreenWidth As Long, ScreenHeight As Long Dim formAllMarginsHeight As Long, formAllMarginsWidth As Long GetScreenResolution ScreenWidth, ScreenHeight ScreenWidth = ConvertPixelsToTwips(ScreenWidth, 0) ScreenHeight = ConvertPixelsToTwips(ScreenHeight, 0) MaxWidth = ScreenWidth * 0.6 maxHeight = ScreenHeight * 0.9 formAllMarginsHeight = f.WindowHeight - f.Section(acDetail).Height formAllMarginsWidth = f.Width formWidth = formAllMarginsWidth formHeight = formAllMarginsHeight If formHeight < f.WindowHeight Then formHeight = f.WindowHeight End If DoCmd.MoveSize (ScreenWidth - formWidth) / 2, (ScreenHeight - formHeight) / 2, formWidth, formHeight End Sub Sub CenterReport(R As Report) Dim ReportWidth As Long, ReportHeight As Long Dim MaxWidth As Long, maxHeight As Long Dim ScreenWidth As Long, ScreenHeight As Long Dim ReportAllMarginsHeight As Long, ReportAllMarginsWidth As Long GetScreenResolution ScreenWidth, ScreenHeight ScreenWidth = ConvertPixelsToTwips(ScreenWidth, 0) ScreenHeight = ConvertPixelsToTwips(ScreenHeight, 0) MaxWidth = ScreenWidth * 0.6 maxHeight = ScreenHeight * 0.9 ReportAllMarginsHeight = R.WindowHeight - R.Section(acDetail).Height ReportAllMarginsWidth = R.Width ReportWidth = ReportAllMarginsWidth ReportHeight = ReportAllMarginsHeight If ReportHeight < R.WindowHeight Then ReportHeight = R.WindowHeight End If DoCmd.MoveSize (ScreenWidth - ReportWidth) / 2, (ScreenHeight - ReportHeight) / 2, ReportWidth, ReportHeight End Sub Function ConvertTwipsToPixels(lngTwips As Long, lngDirection As Long) As Long Dim lngPixelsPerInch As Long Const nTwipsPerInch = 1440 #If VBA7 Then Dim lngDC As LongPtr #Else Dim lngDC As Long #End If lngDC = GetDC(0) If (lngDirection = 0) Then lngPixelsPerInch = GetDeviceCaps(lngDC, WU_LOGPIXELSX) Else lngPixelsPerInch = GetDeviceCaps(lngDC, WU_LOGPIXELSY) End If lngDC = ReleaseDC(0, lngDC) ConvertTwipsToPixels = (lngTwips / nTwipsPerInch) * lngPixelsPerInch End Function Function ConvertPixelsToTwips(lngPixels As Long, lngDirection As Long) As Long Dim lngPixelsPerInch As Long Const nTwipsPerInch = 1440 #If VBA7 Then Dim lngDC As LongPtr #Else Dim lngDC As Long #End If lngDC = GetDC(0) If (lngDirection = 0) Then lngPixelsPerInch = GetDeviceCaps(lngDC, WU_LOGPIXELSX) Else lngPixelsPerInch = GetDeviceCaps(lngDC, WU_LOGPIXELSY) End If lngDC = ReleaseDC(0, lngDC) ConvertPixelsToTwips = (lngPixels * nTwipsPerInch) / lngPixelsPerInch End Function Private Sub GetScreenResolution(ByRef Width As Long, ByRef Height As Long) Dim R As RECT Dim RetVal As Long #If VBA7 Then Dim hWnd As LongPtr #Else Dim hWnd As Long #End If hWnd = GetDesktopWindow() RetVal = GetWindowRect(hWnd, R) Width = R.X2 - R.X1 Height = R.Y2 - R.Y1 End Sub ويتم وضع الكود الاتى فى حدث عند فتح النموذج Call CenterForm(Me) ويتم وضع الكود الاتى فى حدث عند فتح التقرير Call CenterReport(Me)

وكذلك اقول:

وعليكم السلام مشاركه مع اخى واستاذى العزيز اوبمهاب @SEMO.Pa3x جزاه الله عنا كل خير اتفضل التعديل Private Sub s5_AfterUpdate() On Error GoTo ED Dim ss As String Dim QRY As String Set dbs = CurrentDb() QRY = "SELECT * from wer;" Set Q = dbs.OpenRecordset(QRY) ss = "الاسم='" & s5 & "'" Q.FindFirst ss If Not Q.NoMatch = True Then s1 = Q!الرقم_الوظيفي s2 = Q!التاريخ s3 = Q!اليوم s4 = Q!الوظيفة 's5 = Q!الاسم s6 = Q!تاريخ_الالتحاق s7 = Q!تاريخ_الاستقالة s8 = Q!فترة_العمل Else Beep MsgBox "هذا الموظف غير موجود في ملف الموظفين", , "المبرمج" s1 = Null s2 = Null s3 = Null s4 = Null s5 = Null s6 = Null s7 = Null s8 = Null End If AD: Exit Sub ED: Resume AD End Sub Private Sub أمر17_Click() On Error GoTo ED Dim ss As String Dim QRY As String Set dbs = CurrentDb() QRY = "SELECT * from wer;" Set Q = dbs.OpenRecordset(QRY) ss = "الرقم_الوظيفي=" & s1 Q.FindFirst ss If IsNull(s1) Then Beep Exit Sub End If Q.Edit Q!التاريخ = s2 Q!اليوم = s3 Q!الوظيفة = s4 Q!الاسم = s5 Q!تاريخ_الالتحاق = s6 Q!تاريخ_الاستقالة = s7 Q!فترة_العمل = s8 Q.Update s1 = Null s2 = Null s3 = Null s4 = Null s5 = Null s6 = Null s7 = Null s8 = Null s1.SetFocus AD: Exit Sub ED: Beep Resume AD End Sub بالتوفيق موظفين مطلوب نفس الطريقة لكن عند كنابة اسم الموظف وليس الكود.mdb

تفضل جرب المرفق بيانات تلاميذ1.xlsx

أحسنت أستاذ محمد بارك الله فيك وزادك الله من فضله

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

يتم ذلك بطريقتين أولهما :وبما انك لم تقم برفع ملف فسيتم الرد أيضاً بدون ملف 1. انقر قم بتقديم > الخيارات في Excel 2010/2013 ، أو انقر فوق زر المكتب > خيارات إكسيل في Excel 2007. 2. في خيارات إكسيل مربع الحوار، انقر فوق المتقدم من الجزء الأيمن ، وقم بإلغاء تحديد تفعيل مقبض التعبئة وسحب الخلية وإفلاتها الخيار تحت خيارات التحرير قسم في الجزء الأيسر ، انظر لقطة الشاشة أو بهذا الكود Sub Disable_Cell_Drag_Drop() Application.CellDragAndDrop = False End Sub

بارك الله فيك وأكرمك

جزاك الله خير الثواب

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

أحسنت استاذ محمد بارك الله فيك عمل رائع جعله الله فى ميزان حسناتك ولكن من الأفضل طبعاً جعل البرنامج يعمل على النواتين سواء 32 أو 64 بت معاً فالبرنامج يعمل فقط على النواة 32 بت ... ولكم جزيل الشكر

بإختصار الدوال تعني معادلة مثلا معادلة اضافة ايام الى تاريخ محدد DateAdd او معادلة حساب الفرق بين تاريخين DateDeff انصحك تلقي نظرة على منشئ التعابير ستجد بعض الدوال به و كل دالة تحمل شرح مختصر

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

الحمد لله الذي وفقني ووفقك . وعفواً اخي @حامل المسك تحت امرك باي وقت . وبارك الله عليك ووفقك دائماً . شكراً خى @أبو عبدالله الحلوانى لاهتمامك ومرورك الكريم .

بامكانك تعديل الشروط بالاستعلام Final حسب ما تحب ! كما ان التعديل يفي بالمطلوب حسب الشروط الموضحه بالاعلي . واعتذر لك ان لم يصلنى المطلوب بشكل سليم فان امكن التوضيح اكثر وسنصل سوياً للهدف بأمر الله ❤️ .

أحسنت استاذ ماجد بارك الله فيك

تفضل ربما يكون المرفق ما تريد الاكواد اظنها للاستاد ياسر ابو البراء جزاه الله خير الجزاء قمت بتعديلها حسب طلبك قوائم مترابطة (2).xlsm

الاخوة الافاضل لمن يريد معرفة تاريخ نهاية خدمة موظفين اليكم الملف معرفة السن القانوني لتقاعد الموظف.xlsm

جرب هذا الملف TEST TEST.xlsm

وعليكم السلام ... جرب هذا الملف فبه طلبك تاريخ تلقائي 2003.xls

السلام عليكم ورحمة الله وبركاته.. الكثير يجهل امكانية الأكسس في جعل البرامج بشكل responsive أي انه: لو كانت لديك شاشة كبيرة سيتغير شكل برنامجك وتوزيع الأزرار والعناصر لتتناسب مع حجم الشاشة ولو كانت الشاشة صغيرة ايضا ستتغير اماكن العناصر لكي تتناسب مع طبيعة الشاشة وعدم فقدان أي عنصر او ضياعه عندك تغيير الشاشات. قبل البدء، سأقدم لكم مثال على ما اقصده: هذا اخر مشاريعي في الأكسس وهو يتغير تبعاً لأختلاف الشاشات. لنبدأ: سأقوم بوضع Button في منتصف الشاشة بحيث لا يتغير مكانه لو تغير حجم الشاشة ثم قم بعملية الأدراج من جميع الأماكن ( يسار, يمين, أعلى , أسفل ) بحيث يصبح كالأتي: ثم من الطرف اليمين، نختار الأرتساء الأفقي ( كلاهما ) وكذلك الحال بالنسبة لليسار كذلك الحال نطبق على الأعلى والأسفل لكن هذه المرة سوف نعدل الأرتساء العمودي وكذلك بالنسبة للأعلى جرب الآن وسوف ترى ان الـ Button سيبقى في الوسط مهما تغير حجم الشاشة لو وضعت شاشة كبيرة أو صغيرة سيظل بنفس مكانه في الوسط. أي سؤال أنا موجود، تحياتي لكم.

الاخ mmjksa شاهد المرفق اخى __________________________2.rar