نجوم المشاركات
Popular Content
Showing content with the highest reputation on 02/01/20 in all areas
-
جرب هذا الماكرو Sub Fil_combo() Dim k, col, arr(), i%: i = 1 For k = 1 To Sheets.Count col = Sheets(k).Tab.Color If col Then ReDim Preserve arr(1 To i) arr(i) = Sheets(k).Name i = i + 1 End If Next With Me.ComboBox1 .List = Split(Join(arr, ","), ",") .Value = .List(0) End With End Sub COMBO_fil.xlsm3 points
-
3 points
-
السلام عليكم تم عمل المطلوب بمعادلة صفيف... في الملف المرفق. test - Copy.xlsx2 points
-
2 points
-
السلام عليكم توجد العديد من البرامج الخاصة باسترجاع الملفات المحذوفة من الحاسوب منها (Recuva- Recovery My File) تحياتي2 points
-
السلام عليكم بما أن برنامجكم لم يفتح عندي فهو يطلب إصداراً أحدث، فإليكم فكرة العمل- حسب الظاهر لدي من سؤالكم - : ما يلزمكم هو حقل تاريخ ووقت تلقائي فعند إضافة أي سجل جديد سيأخذ تاريخ ووقت الإضافة مما يتيح لكم بالاستعلام أن تحصلوا على السجلات التي أضيفت بتاريخ محدد.2 points
-
ممكن عملها اذا كان رقم 2020 ثابت لا يتغير في حدث بعد التحديث للحقل m p r نضع الكود التالي [Person_in_charge] = [Person_in_charge] & "/2020" اما اذان 2020 يرمز للعام فالافضل انشاء حقل مخفي في النموذج تكون قيمته =Year(Date()) والهدف من ذلك ان سجلات العام القادم تاخذ الملحق /2021 وهكذا للسنوات القادم ويكون الكود على النحو التالي [Person_in_charge] = [Person_in_charge] & "/" & [y_d] y_d اسم الحقل المخفي الخاصة العام يمكن الاستغناء عن الحقل المخفي عن طريق متغيير ولكن دائما الحل الاسهل اسرع في وصول المعلومة للمتلقي المثال مرفق PRODUCT21.mdb2 points
-
تم العمل كما تريد الكود يلون الصفوف الغريبة اوتو ماتيكياً Option Explicit Sub test() Dim RgA As Range, RgC As Range Dim Find_rg As Range, Rgl As Range Dim Dic_Yes As Object Dim m%, x%, R%, arr Set RgA = Sheets(1).Range("A4", Range("A3").End(4)) Set RgC = Sheets(1).Range("C4", Range("C3").End(4)) '=========================== Set Rgl = Sheets(1).Range("L4").CurrentRegion R = Rgl.Rows.Count If R > 1 Then Rgl.Offset(1).Resize(R - 1).Clear End If '============================ Set Dic_Yes = CreateObject("Scripting.Dictionary") For x = 1 To RgA.Rows.Count Set Find_rg = RgC.Find(RgA.Cells(x), lookat:=1) If Not Find_rg Is Nothing Then R = Find_rg.Row arr = Sheets(1).Cells(R, 3).Resize(, 8).Value arr = Application.Transpose(Application.Transpose(arr)) Dic_Yes.Add m, Join(arr, "*") m = m + 1 End If Next For x = 0 To Dic_Yes.Count - 1 Range("L" & x + 4).Resize(, 8).Value = Split(Dic_Yes.Item(x), "*") Next x = x + 4 For m = 1 To RgC.Rows.Count If IsError(Application.Match(RgC.Cells(m), RgA, 0)) Then RgC.Cells(m).Resize(, 8).Copy Cells(x, "L") Cells(x, "L").Resize(, 8).Interior.Color = RGB(0, 204, 255) x = x + 1 End If Next With Range("l4").Resize(x - 4, 8) .Value = .Value .Borders.LineStyle = 1 .Font.Bold = True .Font.Size = 14 .InsertIndent 1 End With Set RgA = Nothing: Set RgC = Nothing Set Find_rg = Nothing: Set Rgl = Nothing Set Dic_Yes = Nothing: Erase arr End Sub Farz1.xlsm2 points
-
وعليكم السلام-اهلا بك بالمنتدى هل تعتقد ان يقوم أحد الأساتذة بتصميم ملف لك لا تنجح وتكتمل اى مشاركة الا برفع ملف اكسيل به المطلوب مع الشرح.... لأنه لا يمكن العمل على التخمين عليك بشرح المطلوب بكل دقة مع وضح النتائج المرجوة وبما انك لم تقم برفع ملف.... فكان عليك لزاما استخدام خاصية البحث بالمنتدى فبه ما تطلب تجميع القبم المكررة2 points
-
استعراض نتائج كل شهر من هذة السنوات باستخدام القائمة المنسدلة2 points
-
2 points
-
2 points
-
السلام عليكم الأخوات الكريمات، الإخوة الكرام هذا المورد الرقمي يشغل على الحاسب بعد فك الضغط عنه وهو مورد رقمي بالأوتوبلاي كان ثمرة دورة تكوينية حول برنامج الأتوبلاي كان لي شرف الإشراف عليها وقد مزجنا في هذا البرنامج بين تقنيات الأتوبلاي و استغلال تقنيات الإكسيل في ميداننا التعليمي خاصة الشق المتعلق باستثمار النقط المورد تفاعلي عبر الترحيب باسم المستخدم وتوديعه وشكره باسمه في نافذة الترحيب يظهر الوقت والتاريخ الحالي المورد يوفر السؤال/ المهمة ووثيقة الإشتغال و الجواب للمقارنة بما أنجزه المستخدم لتتحقق الإفادة بالاضافة لمعادلات إكسيل وشرحها وكتاب رائع حول تعلم VBa بالعربية البرنامج عربي إن ظهرت لكم النوافذ بحروف غريبة ساتفاعل معكم لحل المشكلة التي سببها أن حاسوبكم لايدعم البرامج العربية أتقاسم معكم موردي الرقمي ومورد أحد الإخوة المتوفقين في إنجاز هذا المورد ولا نسألكم إلا الدعاء الصالح بظهر الغيب لي وللأخ عبد الالاه: التحميل من هنا: مورد هشام: https://drive.google.com/file/d/13JZ...ew?usp=sharing مورد عبد الالاه: https://drive.google.com/open?id=1mI...DbKroZoMJcpbey والله ولي التوفيق1 point
-
1 point
-
1 point
-
وجزاك الله الف خير واخونا ابو بسلمة الرسالة هي عندما تضغط على زر جديد فقط واعتذر لم انتبه للخطاء الخاص بالرسالة ولكن ما قام به @احمد الفلاحجي جزاه الله خبرا هو ما كان ينقص الكود1 point
-
1 point
-
تعديل بسيط على كود الاخ صلاح جزاه الله خيرا بملاحظه الاخ السائل لعمل تحديث للنموذج الفرعى بعد الادخال عند عدم الادخال والضغط عالزر سوف تظهر لك الرساله عند الادخال والضغط عالزر سيتم الانتقال لسجل جديد جزاه الله خيرا الاخ @صلاح جبر Private Sub Command24_Click() Me.Child12.Form.Requery If Me.tob = 0 Then MsgBox "ادخل رقم السائق", vbCritical, "صلاح جبر" Me.Child12.SetFocus Else DoCmd.GoToRecord , , acNewRec End If End Sub تقبلوا تحياتى وتمنياتى لكم وللجميع بالتوفيق1 point
-
اخى الفاضل انظر الى الجدول ثم الى الاستعلام عند النقر على الاستعلام سيطلب منك ادخال رقم الفنى ادخل رقم 50 ، 100، 200 ارقام الفنيين سيت فتح الاستعلام على الرقم الذى ادخلته نصيحه من اخ مبتدء اجعل دائما اسماء الحقول والجداول والاستعلامات بالانجليزى حتى لو كتبت مثلا كتاب Ktab حتى لا تتعب فى كتابه الكود ولا تجعل بين الاسماء مسافات اجعل البادئه حرف كبير مثلا LastName او Last_Name تقبل تحياتى وتمنياتى لك وللجميع بالتوفيق 16(1).accdb1 point
-
1 point
-
استاذنا الفاضل / Khalf اشكرك على اهتمامك رغم ان البرنامج لم يفتح عندك فهذا البرنامج للعمل داخل احد الكنترولات على اوفيس 2016 وليس لى حق التغيير فى نسخة الاوفيس لانه بيعمل على اكثر من جهاز لذا أرجو المعذرة اعتقد فكرة تاريخ ووقت عند اضافة سجل جديد لا تتناسب هنا لسبب بسيط لأنه بيتم زيادة عدد الطلاب فى نفس السجل وليس فى سجل جديد اشكرك اخى الفاضل بارك الله فيك وزادك من فضله ما زلت انتظر رد من أحد الإخوة او ممن اكثر منى خبرة ربما نصل الى المطلوب1 point
-
هذا الكود ولا لزوم للخلقات التكرارية Private Sub ToggleButton1_Click() If ToggleButton1 = True Then Call HideBlankRows: ToggleButton1.Caption = "Show_All" Else Call Show_all: ToggleButton1.Caption = "Filter_Me" End If End Sub '++++++++++++++++++++++++++++++++++ Sub HideBlankRows() Dim r%, My_RG As Range Set My_RG = Range("A11").CurrentRegion r = My_RG.Rows.Count My_RG.Offset(1).Resize(r - 1).AutoFilter 6, _ Criteria1:="<=" & Range("k2") End Sub '+++++++++++++++++++++++++ Sub Show_all() If ActiveSheet.AutoFilterMode Then Range("A10").CurrentRegion.AutoFilter End If End Sub الملف مرفق FILTR_No_Filter.xlsm1 point
-
ممتاز اخي صلاح هذا المطلوب ....لاكن كيف الطريقه هل ماكرو ام كود حسب ما رايت انك عملت حساب لعدد السجلات الموجودين في النموذج الفرعي فاذا كانت القيمه صفر تجي الرساله واذا كانت معبئه فالامور في السليم ولاكن اين وضعت هذا الكود If Me.tob = 0 Then MsgBox "ÇÏÎá ÑÞã ÇáÓÇÆÞ", vbCritical, "ÕáÇÍ ÌÈÑ" Me.Child12.SetFocus Else DoCmd.GoToRecord , , acNewRec End If لم اري حدثا في خصائص الحقول او النماذج جزيت خيرا1 point
-
1 point
-
السلام عليكم بعد اذن الاخوة الاعزاء انظر للملفين المرفقين اتمنى ان يكون المطلوب تحياتي استيراد.rar استيراد وحذف وتصدير اكسيل.rar1 point
-
اخى الفاضل راجع هذا الموضوع لعلك تجد به الحل ان شاء الله فلا يوجد لدى سكول سيرفر لاجرب وارى المسارات بعد التحويل تقبل تحياتى وتمنياتى لك وللجميع بالتوفيق1 point
-
1 point
-
لأخي الحبيب @خالد بشير قوانين المنتدى تمنع مثل هذا التصرف راجع قوانين المنتدى أخي الكريم 1- يمنع منعا باتا نشر أية مواد تخالف حقوق الملكية الفكرية و يرجى الابلاغ عن المشاركات المخالفة من خلال زر تقرير اسفل المشاركة 2-يجب استخدام خاصيةالبحث قبل طرح السؤال توفيرا للوقت و الجهد. 3-ضرورة كتابة عنوان واضح للموضوع يدل على محتواه ويعطي وصفاً مختصرا للسؤال. 4-ممنوع منعا باتاً كتابة عناوين سينمائية مثل عاجل ، نداء الي فلان ، الي الخبراء ، طلب مساعدة ، أريد حلا..... 5-يمكن استعجال الرد باستخدام تعبير -للرفع- و غير مسموح بالالحاح او اللوم فجميع الاعضاء يشاركون تطوعا طبقا لسعة وقتهم. ومخالفة ذلك تعرض الموضوع للحذف1 point
-
تفضل أخي في انتظار تدخل الاساتذة والخبراء في المجال أدخل بياناتك في شيت 1 البحث في الشيتات - وجمع المكرر.xlsm1 point
-
السلام عليكم بعد اذن اخي محمد هذه قكرةرائعىة انه يخصص الشخض قاعدة بيانات فارعة وليس سيرفر لارشفة الجداول المهمة في جميع قواعد البيانات لنفرض فاعدةالبيانات المراد ترحيل الجدولayman1 والقاعدة الفارغة archieve Dim db As DAO.Database Dim blnTrans As Boolean Dim strSQL As String Dim strPath As String Dim strDb As String Dim strDateCriteria As String ' On Error GoTo ErrorHandler strPath = "C:\AYMAN71\" strDb = "ayman1.accdb" strDateCriteria = _ "BETWEEN #1/1/2000# AND #12/31/2022#;" DBEngine.BeginTrans blnTrans = True Set db = OpenDatabase(strPath & strDb) ' نسخ جدول orders ' وتصديره ثم حذفه strSQL = _ "SELECT * INTO origin IN " & _ Chr(34) & strPath & strDb & Chr(34) & _ " FROM Orders WHERE Orders.OrderDate " & _ strDateCriteria db.Execute strSQL, dbFailOnError ' تاكبد If MsgBox("Click OK if you want to archive " _ & db.RecordsAffected & _ " records.", vbOKCancel + _ vbQuestion + vbDefaultButton2, _ "Proceed?") = vbOK Then DBEngine.CommitTrans DoCmd.TransferDatabase acImport, "Microsoft Access", "C:\ayman71\ayman1.accdb", acTable, "origin", "archive" db.TableDefs.Delete ("origin") Application.RefreshDatabaseWindow Else If blnTrans Then DBEngine.Rollback End If If db.RecordsAffected = 0 Then DBEngine.Rollback MsgBox "لا حركات " & _ "with the specified criteria.", _ vbInformation + vbOKOnly, _ "Records not found" End If Cleanup: Set db = Nothing Exit Sub1 point
-
اضافة أمر حفظ سجل قبل تشغيل SQL DoCmd.RunCommand acCmdSaveRecord لازم اضافة هذا امر Edit123.accdb1 point
-
وعليكم السلام-تفضل تعديل على قاعدة بيانات وحذف البيانات القديمة منها كود لحذف محتويات مجلد1 point
-
بعد اذن الاخ علي جرب هذا الكود Option Explicit Sub Salim() Dim My_rg1 As Range, RO%, m%, n%, x% Dim Arr1, Ful_arr(), Arr2() Set My_rg1 = Range(Sheets(1).Range("A4"), Sheets(1).Range("A4").End(4)) Arr1 = Application.Transpose(My_rg1) RO = Sheets(2).Cells(Rows.Count, 1).End(3).Row Sheets(2).Range("C4").CurrentRegion.Clear m = 1: n = 1 For x = 4 To RO If IsError(Application.Match(Sheets(2).Range("A" & x), Arr1, 0)) Then ReDim Preserve Arr2(1 To m) Arr2(m) = Sheets(2).Range("A" & x).Value m = m + 1 Else ReDim Preserve Ful_arr(1 To n) Ful_arr(n) = Sheets(2).Range("A" & x).Value n = n + 1 End If Next With Sheets(2).Range("C4").Resize(n - 1) .Value = Application.Transpose(Ful_arr) .Borders.LineStyle = 1 .Interior.ColorIndex = 20 .Font.Bold = True .Font.Size = 14 .InsertIndent 1 If m <> 1 Then With .Offset(n - 1).Resize(m - 1) .Value = Application.Transpose(Arr2) .Borders.LineStyle = 1 .Interior.ColorIndex = 19 .Font.Bold = True .Font.Size = 14 .InsertIndent 1 End With End If End With Erase Arr1: Erase Ful_arr(): Erase Arr2() End Sub الملف مرفق Tartib.xlsm1 point
-
1 point
-
وعليكم السلام - تفضل الم تطلع على الملف تم تنفيذ المطلوب بهذا الكود Sub arrange() Sheet1.Activate Columns("A:A").Select Selection.Copy Sheet2.Activate Columns("b:b").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False End Sub ترتيب بيانات الصفوف حسب القائمة الأساسية.xlsm1 point
-
عليك السلام ورحمة الله وبركاته بعد إذن الأستاذ khalf كان لزامًا عليك استخدام خاصية البحث في المنتدى1 point
-
1 point
-
جزاك الله خير استاذ اسامه ابو طارق وايضا للاخ احمد يوسف على المشاركه بارك الله فيكم1 point
-
1 point
-
1 point
-
الحمدلله لا تنسي تغير هذا السطر في موديول SetUp Public Const Ext = "*.xls" الي Public Const Ext = "*.xlsx" مع اطيب تمنياتي بالتوفيق شاهد المرفقات Test_1.rar1 point
-
1 point
-
هل من الممكن الملف المثال السابق ارفاق الملفات الفرعية له لأعمال المرجعة والتأكد من صحة نقل البيانات او عمل مثال من ملفات فرعية ورئيسى فقد وصلت لمرحلة ضبط التنسيق ثم يأتي دور المراجعة والتدقيق لعلي لا اثقل عليك تحياتي لك1 point
-
السلام عليكم تفضل المعادلة الموجودة بالخلية B11 بعد إضافة معادلة مساعدة في العمود G =IFERROR(VLOOKUP(1,D7:G18,4,0),"ادخل رقم حساب الصنف بالخليةc3") if طويلة.xlsm1 point
-
أخي الحبيب الأستاذ/ حيدر وعليكم السلام ورحمة الله وبركاته تم تنفيذ الفورم ووضع بعض الاكواد بالمرفقات للاطلاع عليه وقم بحفظ الصور بالمجلد المرفق بالفورم جرب واعلمني بالنتيجة لاستكمال العمل استمارة معلومات العائلة الالكتروني.rar1 point
-
بإمكان المبرمج إغلاق النموذج المفتوح بناء على فترة زمنية لم يستخدم فيها المستخدم الحاسوب سواء الفأرة (Mouse) أو لوحة المفاتيح (Keyboard) وذلك بتعريف عدة أحداث كما يلي: 1. حدث عند التحميل OnLoad Private Sub Form_Load() Me.TimerInterval =20 'تعريف الوقت المطلوب قبل الانهاء End Sub حيث أن TimeInterval هو زمن الانتظار قبل الإغلاق بالمللي ثانية 2. حدث عند عداد الوقت FormTimer Private Sub Form_Timer() DoCmd.Quit 'للخروج من النموذج End Sub 3. حدث عند النقر Click وحدث عند الضغط على مفتاح Private Sub Form_Click() Me.TimerInterval = 20 ' إعادة تعريف الوقت End Sub Private Sub Form_KeyPress(KeyAscii As Integer) Me.TimerInterval = 20 ' إعادة تعريف الوقت End Sub1 point
-
السلام عليكم مرفق مثال أخر يوضح كيفية حماية قاعدة البيانات وذلك بإغلاقها, اذا لم يحرك المستخدم مؤشر الماوس او الكتابة على لوحة المفاتيح خلال فترة زمنية يتم تحديدها مسبقاً واترك لباقي الزملاء التعديل او طرح طرق أخرى مع تحياتي SecureDatabase.zip1 point
-
وهناك حل افضل قليلا وهو ربط غلق البرنامج بحدوث Screen Saver فعليا وربما كان ذللك معبرا فعليا عن المستخدم كف عن استخدام البرنامج وكذلك ان ضبط screen Saver معبر عن رغبة المستخدم بدلا من تضايقه من غلق البرنامج قصرا عنه الخطوات: 1-ندخل Module ونكتب فيه ننقل فيه الأكود الاتية 'http://www.littleguru.com '================================= Public Declare Function EnumWindows& Lib "user32" (ByVal lpEnumFunc As Long, ByVal lParam As Long) Public Declare Function GetWindowText& Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) Private strAppTitle As String Private lngHwnd As Long Public Function IsRunning&(strTitle As String) lngHwnd = 0 strAppTitle = strTitle EnumWindows AddressOf EnumWinProc, 0 If lngHwnd <> 0 Then IsRunning = lngHwnd Else IsRunning = 0 End If End Function Private Function EnumWinProc&(ByVal lhWnd As Long, ByVal lParam As Long) Dim WinTitleBuf As String * 255 Dim WinTitle As String GetWindowText lhWnd, WinTitleBuf, 255 WinTitle = StripNulls(WinTitleBuf) If InStr(WinTitle, strAppTitle) <> 0 Then lngHwnd = lhWnd EnumWinProc = False Exit Function End If EnumWinProc = True End Function Private Function StripNulls(OriginalStr As String) As String If (InStr(OriginalStr, Chr(0)) > 0) Then OriginalStr = Left(OriginalStr, InStr(OriginalStr, Chr(0)) - 1) End If StripNulls = OriginalStr End Function 2- فى النموذج نضع الفاصل الزمنى المناسب بالمللى ثانية وهذا الفاصل لا يستخدم لغلق البرنامج بل كل فاصل زمنى يتم اختبار ما إذا كان الscreen Saver يعمل فإذا كان يعمل يقوم بغلق البرنامج ويتم نسخ هذا الكود فى حدث OnTimer للنموذج : Private Sub Form_Timer() Dim strApp As String strApp = "Screen Saver" If IsRunning(strApp) > 0 Then Application.Quit End If End Sub وما زال يعيبها أن تتم من خلال نموذج ولا يوجد حدث فى Application لكى يتم ربط الدالة به ..... مع تحياتى وخالص الشكر للاستاذ أبى أفنان على هديته أكواد خاصة بالكسس1 point
-
فى الحقيقة الطريقة السابقة تغلق قاعدة البينات اتوماتيكيا بعد 10000 مللى ثانية ولكن ليس هذا هو المطلوب تماما وذلك لأن قاعدة البيانات ستغلق حتى لو كان المستخدم يستخدم الفأرة ولوحة المفاتيح أى الغلق يتم دونما شرط او قيد يكون تعديلها بالطريقة الاتية 1-ندخل Module ونكتب فيه الجملة الاتية Global SumofEvents1 As Integer, SumofEvents2 As Integer 2- فى النموذج يتم عمل الاتى خاصية Timer Interavels =180000 (milli-Second) تكتب هذه الدوال فى كود النموذج Private Sub Form_KeyPress(KeyAscii As Integer) If SumofEvents1 > 32000 Then SumofEvents1 = -32000 SumofEvents1 = SumofEvents1 + 1 End Sub Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) If SumofEvents1 > 32000 Then SumofEvents1 = -32000 SumofEvents1 = SumofEvents1 + 1 End Sub Private Sub Form_Timer() If SumofEvents1 = SumofEvents2 Then Application.Quit Else SumofEvents2 = SumofEvents1 End If End Sub والفكرة أنه يتم تعريف متغيريين ونقوم بيادة 1على المتغير الأول عند حدوث أى حدث - يمكن تكرار S Sub Form_MouseMove فى كل الأحداث المطلوب ان تعبر عن ان المستخدم متواجد أمام الكمبيوتر كل فاصل زمنى تقوم Sub Form_Timer بتخزين القيمة عند هذا الفاصل غى المتغير وكل فاصل زمنى تقوم باختبار المتغييرن ومعنى تساويهما أنه لم يتم أى حدث بين الفاصلين وهنا نغلق قاعدة البينات العيوب: 1-يجب تكرار الدوال لكل مقاطع النموذج حيث أن تحرك الماوس على مقطع Detail بسسب الحدث Detail_MouseMove وهكذا 2- فى حالة عمل Minemize للنموذج لن يسجل أى أحداث للماوس والكيبورد مما قد يؤدى ألى غلق قاعدة البيانات بينما المستعمل يقوم بأحداث على مكان أخر 3-أيضا فى حالة فتح نموذج الى هذا النموذج بمساحة أكبر يستقبل النموذج الثانى كل الأحداث وتؤدى إلى النتيجة السابقة1 point
-
أحبتي في هذا برنامج وهو جميل جداً جداً لكتابة الاكسس وجدته منذ فترة فقمت بحذف الاكواد الموجود فيه وكتب وجمعت أكواد خاصة بالاكسس والى الآن لم أنتهي من جمع الاكواد ولكن أحببت أن أستعجل في إنزاله ولى عودة لهذا الموضوع مرة إخرى تحياتي أكواد الاكسس.rar1 point