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

اخي الكريم طلبك موجود ضمن الكود و لست بحاجة لانشاء رسالة اخرى في حال ان الاتصال فشل سوف تظهر الرسالة ادناه VBA.MsgBox "Error " & err.Number & " (" & err.Description & ")" لكن تستطيع اضافة رسالة في حال نجاح الاتصال و لا انصح بها لأنه في كل الاحوال سيتم استخدام الكود في نموذج الواجهة الرئيسية ففي كل مرة يتم الدخول للواجعة سوف تظهر رسالة تفيد بنجاح الربط و هذا غير منطقي شكرا لك...

الاخوة الاعزاء تجدون في المرفقات فكرة في طور التطوير لعمل قوائم بأبسط الطرق و بالأدوات المتاحة آمل المزيد من اقتراحاتكم شكرا لكم ... . برنامج شئون الموظفين.rar

أحسنت أستاذ مجدى عمل رائع جعله الله في ميزان حسناتك

استاذى الكريم الأمر في غاية البساطة بالنسبة لملفك فعليك بالضغط كليك يمين على اسم الصفحة التي تظهر لديك بالملف ثم الضغط على UNhide كما بالصور لإختيار الصفحة التي تريد اظهارها

وعليكم السلام-اهلا بك في المنتدى -تفضل بلاغات.xlsm

أحسنت أستاذ أبو اَمنة عمل رائع بارك الله فيك وجعله في ميزان حسناتك

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

وعليكم السلام-تفضل هذا الكود Option Explicit Sub opening_multiple_file() Dim i As Integer With Application.FileDialog(msoFileDialogFilePicker) .AllowMultiSelect = True .Filters.Clear .Filters.Add "Excel Files", "*.xls*" If .Show = True Then For i = 1 To .SelectedItems.Count Workbooks.Open .SelectedItems(i) Next i End If End With End Sub

الأمر بسيط وسهل جدا عدل في الكود الى رقم الصف الذى تريده عليك بتغيير الرقم 24 الى الرقم المراد بارك الله فيك

المعادلة تعمل بكل كفاءة وتم تجربتها

فورم ترحيل بيانات عمودى وافقى الفيديو الصور

If Not IsNumeric([أسم الحقل ]) Then MsgBox "يجب ادخال ارقام في هذا الحقل", 48, "ادخـال خـاطـئ !" End if If Len([أسم الحقل]) <> 10 Then MsgBox "يجب ادخال عشرةارقام في هذا الحقل", 48, "ادخـال خـاطـئ !" End if ::بالتوفيق::

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

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

تفضل .... برنامج مسابقة الحماية والاستمار.accdb

جرب المحاولة هذه .... InvoiceSale_8_2.rar

على كل حال اذا كنت تريدها بواسطة الماكرو Option Explicit Sub sum_befor_date() Dim i%, x%, s#, My_date As Date Dim k%: k = 3 My_date = [CA1] Range("CA3", Range("CA2").End(4)).ClearContents x = Cells(1, Columns.Count).End(1).Column - 1 Do Until Cells(k, 3) = vbNullString For i = 3 To x Step 2 If CDate(Cells(3, i + 1)) > My_date Then Exit For s = s + Cells(3, i) Next Cells(k, "CA") = s: s = 0 k = k + 1 Loop End Sub

السلام عليكم الحل على حسب عنوان الموضوع أخي @hassam0k New Microsoft Access Database (2).accdb افتح استعلام Q1 و انظر النتيجة

MP3_WAV_Player_SEMO_Pa3x.accdb

تفضل ::بالتوفيق:: elements906.accdb

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

اخي لدي مشروع قريب من الذي لديك قد تجد فيه ما يفيدك تفضل في المرفقات برنامج شئون الموظفين.rar

تفضل هذه فكرة اخرى إخفاء أو إظهار التقرير.accdb

وكيف سيتم التطبيق ؟

مشاركة مع الاخوة برغم اني لم اشوف ماكان جوابهم لعل الافكار تختلف إخفاء أو إظهار التقرير.accdb

فبل التحديث If Len(رقم_الجوال) <> 10 Then MsgBox " فـضـلاً أدخـل عـشـرة أرقـام فـقـط ولـيـس اقـل او اكـثـر ", vbExclamation, " : خـطـاء " cancel = True 'هذاالسطر والا تحته يعيد التركيز لنفس الحقل' cancel = True Me.رقم_الجوال.Undo End If عند الضغط على مفتاح Dim Chkstr As String Chkstr = "0123456789" If KeyAscii > 26 Then 'اي ان المفتاح الذي تم نقره ليس من ضمن مفاتيح التحكم مثل Ctrl If InStr(1, Chkstr, Chr(KeyAscii)) = 0 Then KeyAscii = 0 MsgBox " فـضـلاً أدخـل أرقـام فـقـط ولـيـس حـر و ف ", vbInformation, " : خـطـاء " End If End If

تفضل .... Lab.rar

اخي الكريم هذا كود بسيط لعملية الربط المهم ان تكون قاعدة البيانات في نفس مسار البرنامج انشئ موديل و الصق التالي مع التعديل كما هو موضح Option Compare Database Option Explicit Public Function updateTableLinks() On Error GoTo updateTableLinks_Err Dim varThis As Variant Dim strBEFileSpec1 As String dim x x=CurrentProject.Path & "\" & "اسم قاعدة البيانات"& ".mdb" ' او ضع مسار قاعدة البيانات strBEFileSpec1 = x For Each varThis In CurrentDb.TableDefs With varThis If Trim(Nz(.Connect)) Like ";DATABASE=*" Then .Connect = ";DATABASE=" & strBEFileSpec1 .RefreshLink End If End With Next varThis updateTableLinks_Exit: Exit Function updateTableLinks_Err: If Err.Number > 0 Then Resume Next Else MsgBox Err.Description Resume updateTableLinks_Exit End If End Function في حدث عند الفتح في نموذج الواجهة استدعي Call updateTableLinks

@العنكوش تفضل اخي اسم المستخدم hussam كلمة السر 1234 تربية_حاسبات.rar

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

اذا كانت الاجابة صحيحة اضغط عليها حتى تعم الفائدة

جرب هذا الماكرو Private Sub ComboBox1_Change() Application.EnableEvents = False On Error Resume Next ''''''''''''''''''''''''''''' Dim sheet_to As Worksheet Dim t$: t = ComboBox1.Value Dim My_name$ Dim My_rg As Range Select Case t Case "راسب": My_name = "رسوب" Case "ناجح": My_name = "ناجح" Case "دور ثانى": My_name = "دور ثان فى" End Select Set My_rg = Sheets("الشيت").Range("a4").CurrentRegion On Error Resume Next Sheets(My_name).Cells.Clear My_rg.AutoFilter 20, t My_rg.SpecialCells(12).Copy Sheets(My_name).Range("a4") If Sheets("الشيت").FilterMode Then Sheets("الشيت").ShowAllData: My_rg.AutoFilter End If Application.EnableEvents = True End Sub الملف مرفق Shool.xlsm

تفضل لك ما طلبت فاتورة على الفورم2.xlsm

عليك السلام ورحمة الله وبركاته ممكن هكذا على حجم ورق A4 وأحيانًا ويمكن تقليل أو زيادة عرض أي عمود مع الاحتفاظ بظهور الكتابة فقد تم عمل احتواء مناسب للخلايا test.xlsx

الحمد لله على توفيقه ....

جيد جداً شكرا لك اخي ..... هذا الجواب صحيح ..... هذا ما اريد ....

بارك الله فيك استاذ سليم عمل ممتاز

تفضل 2018-2019قوائم الفصول.Xls دفترالتنقيط.xlsx

.

تفضل لك ما طلبت الاول.xlsm

بارك الله فيك

لا يمكن بطريقتك هذه بل يمكن بهذه الطريقة 2التفقيط.xls

وعليكم السلام -تفضل التفقيط بالمعادلات2018 .xlsx

احسنت استاذ سليم كود رائع جعله الله فى ميزان حسناتك

ممتاز استاذ ابراهيم عمل رائع جعله الله فى ميزان حسناتك

يمكنك رؤية هذا الفيديو https://www.youtube.com/watch?v=tAcC_GTZ38o

وعليكم السلام , اهلا بك اخى الكريم فى المنتدى عليك بوضع هذا الكود فى حدث الصفحة التى تقوم بالكتابة عليها Private Sub Worksheet_Change(ByVal Target As Range) Cells.Select Selection.Rows.AutoFit Selection.Columns.AutoFit Range("A1").Select End Sub وذلك عن طريق كليك يمين فى الأسف على اسم الصفحة ثم View Code ستفتح لك نافذة اخرى عليك لصق هذا الكود بها بارك الله فيك وموفق ان شاء الله

تفضل جلب البيانات بثلاث شروط2.rar

بالتأكيد هذا يسمى ابداع احسنت استاذى الكبير سليم عمل رائع بارك الله فيك وجعله فى ميزان حسناتك واكثر الله من امثالك وزادك الله من فضله

تفضل 1تقريب.xlsx