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

تفضل <<<<<<<>>>>>>>> Kan_20211007.rar

طيب <<<<<<>>>>>>> هل المدة المعلمة باللون الازرق هي مدة الاقتطاع أم ماذا تمثل في الجدول ؟؟؟؟

طيب جرب <<<<<<<<>>>>>>>>> 20211007 (1).rar

الكود ليس فيه جديد ( هو استعلام ولكن عن طريق VB فقط ) لو قمت بنسخ هذا الجزء مثلا والصقتة في طريق عرض SQL في الاستعلام يظهر لك الاستعلام INSERT INTO 1 ( [رقم الكتاب], [تاريخ الكتاب], الاسم, الوظيفة, الموضوع, [اسم المستلم], [تاريخ الاستلام], المرحلة ) SELECT المعاملات.[رقم الكتاب], المعاملات.[تاريخ الكتاب], المعاملات.الاسم, المعاملات.الوظيفة, المعاملات.الموضوع, المعاملات.[اسم المستلم], المعاملات.[تاريخ الاستلام], المعاملات.المرحلة FROM المعاملات WHERE (((المعاملات.[رقم الكتاب])=[Forms]![ادخال بيانات]![رقم الكتاب])); ثم في حدث الزر استدعيه بهذه الصورة فلن تعمل رسائل التحذير .... طبعا هذه طريقة وهناك طرق اخرى .. DoCmd.SetWarnings False DoCmd.OpenQuery "استعلام1" DoCmd.SetWarnings True

لاضافة جدول في قاعدة خارجية استخدم الاتي <<<<<<<>>>>>>>> Dim msgstyle Dim strSQL1 As String Dim b As New Access.Application Set b = CreateObject("Access.Application") b.OpenCurrentDatabase (Me.txtPath) strSQL1 = "CREATE TABLE [kanory] ([ProductID] AUTOINCREMENT,[ProductName] TEXT(40) NOT NULL,[SupplierID] LONG,[BirthDate] DATETIME,[CategoryID] LONG,[QuantityPerUnit] TEXT(20),[UnitPrice] CURRENCY,[UnitsInStock] SMALLINT,[UnitsOnOrder] SMALLINT,[ReorderLevel] SMALLINT,[Discontinued] BIT NOT NULL,CONSTRAINT [PrimaryKey] PRIMARY KEY ([ProductID]));" b.DoCmd.RunSQL strSQL1 MsgBox Space(20) & "تم انشاء الجدول Kanory بنجاح.." & Space(20), msgstyle, "للمعلومية" Set b = Nothing اما لتعديل خصائص حقل موجود في الجدول استخدم التالي مع ملاحظة : ان اختلاف البيانات قي الحقل اذا كانت هنا بيانات ممكن تفقدها :::: <<<<<>>>>>>> Dim msgstyle Dim b As DAO.Database Dim strFieldName As String Set b = DBEngine.OpenDatabase(Me.txtPath) With b.TableDefs("Kanory").Fields("S_Name") .Properties.Append .CreateProperty("DisplayControl", dbInteger, AcControlType.acComboBox) .Properties.Refresh End With MsgBox Space(20) & "تم انشاء الجدول Kanory بنجاح.." & Space(20), msgstyle, "للمعلومية" b.Close Set b = Nothing

هذا الكلام في المرفق ام برنامجك ........... وماهي رسالة الخطأ التي تظهر .....

تم التطبيق على المرفق <<<<<<<>>>>>>> تجريبي (1).rar

السلام عليكم ورحمة الله الاخ ABOU ELSAAD يمكنك استخدام الكود التالى Sub AbsCount() Dim ws As Worksheet, LR As Long Dim x As Long Dim a As Integer, b As Integer, d As Integer Dim C As Range, Abst As String Const Com = "," Set ws = Sheets("SS") x = 3 LR = ws.Range("AG" & Rows.Count).End(xlUp).Row Do While x <= LR For Each C In ws.Range("A" & x & ":AE" & x) If C.Value > 0 Then a = WorksheetFunction.Min(ws.Range("A" & x & ":AE" & x)) b = WorksheetFunction.Max(ws.Range("A" & x & ":AE" & x)) ab = b - a + 1 d = WorksheetFunction.Count(ws.Range("A" & x & ":AE" & x)) If ab = d And d > 1 Then Abst = " يوم " & " (" & a & " - " & b & ")" ws.Range("AL" & x) = Abst Else Abst = C.Value & Com & Abst ws.Range("AL" & x) = Left(Abst, Len(Abst) - 1) End If End If Next C Abst = "" x = x + 1 Loop End Sub

من تبويب ملف file ثم خيارات options ثم متقدم advanced يوجد قوائم مخصصة custom lists تأكد من وجود أسماء الأيام والشهور باللغة العربية وإلا فيجب إضافتها كل عنصر في سطر وبالنسبة لتنسيق الأرقام فيجب اختيار منطقة عربية في لوحة التحكم في تنسيق التاريخ والأرفام بالتوفيق

تفضل جرب المرفق الترحيل معدل.xlsm

يمكنك استعمال هذه المعادلة =TEXTJOIN(CHAR(10),1,A2:C2) مع تغيير تنسيق الخلية إلى التفاف النص wrap text وإذا لم تكن دالة textjoin مدعومة فيوجد موضوع لي عن بدائل لها mastextjoin بالتوفيق

طيب جرب المرفق هذا <<<<<<<>>>>>>>> al3beadlly.rar نافذة الرسائل بسيطة يمكن تلافيها وعدم ظهورها .....

تفضل <<<<<<<<<>>>>>>>>> al3beadlly.rar

ممكن مثال صغير للفكرة التي تريدها

واضح الرسالة تظهر قبل الضغط على زر ارسال البيانات ... صحيح

بعد إذن أخي الكريم @ابراهيم الحداد لا نحتاج لعكس الكلام لأنه يظهر الأرقام مقلوبة مثل 13 تظهر 31 وهكذا هذا جهدي المتواضع في هذا المجال Sub AbsDays() Dim ws As Worksheet, C As Range, LR As Long, x As Long Set ws = Sheets("SS") LR = ws.Range("AG" & Rows.Count).End(xlUp).Row For x = 3 To LR ws.Range("AI" & x) = "" For Each C In ws.Range("A" & x & ":AE" & x) If C.Value > 0 Then ws.Range("AI" & x) = ws.Range("AI" & x) & IIf(ws.Range("AI" & x) = "", "يوم ", " و") & C.Value Next C : Next x MsgBox "Done by mr-mas.com" End Sub بالتوفيق ترحيل أيام الغياب.xlsb

جرب تغير هذا الكود <<<<<<>>>>>>>>> Fol.AllowMultiSelect = False بهذا ........... Fol.AllowMultiSelect = True

جرب المرفق <<<<<<<<>>>>>>>>> Kanory.accdb

يا اخي هل طبقك الكود قبل السؤال .... وفتحت على خصائص الجدول ..... ؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟

تفضل <<<<<<<<<>>>>>>>>> Dim strSQL1 As String strSQL1 = "CREATE TABLE [kanory] ([ProductID] AUTOINCREMENT,[ProductName] TEXT(40) NOT NULL,[SupplierID] LONG,[BirthDate] DATETIME,[CategoryID] LONG,[QuantityPerUnit] TEXT(20),[UnitPrice] CURRENCY,[UnitsInStock] SMALLINT,[UnitsOnOrder] SMALLINT,[ReorderLevel] SMALLINT,[Discontinued] BIT NOT NULL,CONSTRAINT [PrimaryKey] PRIMARY KEY ([ProductID]));" DoCmd.RunSQL strSQL1 اسف اخي الكريم @عبد اللطيف سلوم يبدو ان المشاركيتن في في الوقت .... لكن الطريقتين مختلفتين للفائدة .....

مشاركة مع حبايبنا الاساتذة <<<<<<<<>>>>>>>> DATA2.accdb

واياك استاذنا الفاضل ابا الحسن ... جزاك الله خيرا

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

طيب ... جرب الكود هذا <<<<<<<<<>>>>>>>>> DoCmd.RunCommand acCmdSaveRecord If Val(outs) <= Val(a) Then Me.a = [Forms]![Form1]![a] - [Forms]![Form1]![outs] ElseIf Val(outs) > Val(a) And Val(a) > 0 Then MsgBox "الرصيد الحالي لا يغطي التسديد" ElseIf Val(a) = 0 And Val(outs) <= Val(m) Then Me.m = [Forms]![Form1]![m] - [Forms]![Form1]![outs] ElseIf Val(outs) > Val(m) And Val(a) = 0 Then MsgBox "التسديد اكبر من رصيد اول المدة" End If

لم افهم ... اعذرني لكبر سني ... ممكن مثال للفهم

طيب جرب الحدث التالي <<<<<<<<>>>>>>>>> DoCmd.RunCommand acCmdSaveRecord If Me.outs <= Me.a Then DoCmd.SetWarnings False DoCmd.RunSQL "UPDATE t1 SET t1.a = [Forms]![Form1]![a]-[forms]![Form1]![outs] WHERE (((t1.kan_id)=[Forms]![Form1]![kan]))" DoCmd.Requery DoCmd.SetWarnings True ElseIf Me.outs > Me.a And Me.a > 0 Then MsgBox "الرصيد الحالي لا يغطي التسديد" ElseIf Me.a = 0 And Me.outs <= Me.m Then DoCmd.SetWarnings False DoCmd.RunSQL "UPDATE t1 SET t1.m = [forms]![Form1]![m]-[Forms]![Form1]![outs] WHERE (((t1.kan_id)=[Forms]![Form1]![kan]))" DoCmd.Requery DoCmd.SetWarnings True ElseIf Me.outs > Me.m And Me.a = 0 Then MsgBox "التسديد اكبر من رصيد اول المدة" End If اشكرك يا بشمهندس ........ منكم تعلمنا

طيب جرب المرفق حسب فهمي للموضوع <<<<<<<<<<>>>>>>>>>> اضفتا حقل ترقيم ... الخصم.accdb

اعانك الله اخي عمر وعوضك خيرا ..... اخي الكريم .... نصيحة اخ .. دائما وابدا اعمل نسخ احتياطية لبرامجك سواءا وقت التصميم او وقت العمل عليه ....

القاعدة معطوبة انظر نتيجة الفحص ......

برنامج شئون العاملين الباسوورد 2545 برنامج شئون العاملين.rar

السلام عليكم كيف أضف حقول في التقرير الصفحة الثانية بعد إمتلاء الصفحة الأولى للعلم a3 وشكرا

أ.محمد صالح شكرا جدا يا فندم عاجز عن الشكر شكرا جدا جدا انا عاجز عن شكرك يا فندم

Sub Test() Dim a, v, w1 As Worksheet, w2 As Worksheet, dic As Object, s As String, i As Long, m As Long, cnt As Long Set w1 = Sheet1: Set w2 = Sheet2 Set dic = CreateObject("Scripting.Dictionary") a = w1.Range("A4").CurrentRegion.Value For i = 2 To UBound(a) s = a(i, 1) & Chr(2) & a(i, 2) & Chr(2) & a(i, 3) dic(s) = Empty Next i With w2 For i = 5 To .Cells(Rows.Count, 1).End(xlUp).Row s = Empty s = .Cells(i, 1) & Chr(2) & .Cells(i, 2) & Chr(2) & .Cells(i, 3) If Not dic.Exists(s) Then m = w1.Cells(Rows.Count, 1).End(xlUp).Row + 1 v = Split(s, Chr(2)) w1.Range("A" & m).Resize(1, 3).Value = v cnt = cnt + 1 End If Next i End With If cnt > 0 Then MsgBox "New Items Added = " & cnt, 64 Else MsgBox "No New Items", vbExclamation End Sub

ينبغي مدارسة المعادلة وفهم بداية ونهاية كل نطاق ورقم الصف والعمود المطلوب وبإذن الله تستطيع الوصول للمطلوب الثاني بنفسك خالص دعواتي بالتوفيق

لو تكرمتم ممكم اضافة عموددين الحالة واللغة فى القائمة والف شكر فى المف السابق

مشاركة قاعدة البيانات على جهاز mycloudex2ultra الموضوع مطروح للأفكار والنقاش للأستفادة منه وهو يعتبر الجيل الجديد من السيرفيرات المصغرة توجد العديد من الأنواع . لكن هذا النوع الذي أعمل عليه و قمت بتجربته مشاركة قاعدة البيانات البسيطة و محدودة المستخدمين على جهاز كمبيوتر مشاكلها كثيرة وتتطلب الدعم الفني بصفة مستمرة . . . لكن حين الأنتقال للجيل الجديد تبدو المشاركة بسيطة وسلسة و مستوى أمان عالي على مستوى المستخدمين وقاعدة البيانات ومن مميزاتها : سهولة توصيله مع الرواتر النسخ المتماثل للسيرفير المصغر بواسطة تقنية RAID 1 و العديد من تقنيات النسخ النسخ الأحتياطي الأوتوماتيك للقاعدة الخلفية الربط المتباعد بين الفروع عن طريق ربط الجهاز بالأنترنت متجر لتنزيل التطبيقات المخصصة لقواعد البيانات و الصيانة و نشر المحتوى سهولة التعامل مع لوحة التحكم من مميزاته في حالة قيام المستخدم بحذف ملف بالخطأ من مجلد المشاركة يتم نقله إلى مجلد خاص TimeMachineBackup تطبيق ربط الطابعات و أجهزة الماسح الضوئي على السيرفير . يتطلب أشتراك رمزي مدفوع تحديث أوتوماتيك لــ Firmware يمكن أنشاء نموذج ووضع ال ip بالمستعرض داخل تطبيق الأكسيس حتى يمكن التعامل معه بسهولة كل هذه تعتبر الوجبة . . لكن ماهي النكهة . أنه : phpMyAdmin مدمج و مجاني ماعليك سوى تنزيله من متجر التطبيقات وهو تطبيق قواعد البيانات SQL أذا أردت تطوير قاعدة بيانات الأكسيس و الأنتقال لقواعد البيانات sql لا تحتاج سوى نصف ساعه . . والله الموفق

الف شكر جزاكم الله كل خير

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

Sub Test() Dim a a = GetDates(Range("D1").Value2, Range("F1").Value2) Range("D3").Resize(UBound(a)).Value = Application.Transpose(a) End Sub Function GetDates(ByVal startDate As Date, ByVal endDate As Date) Dim v() As Date, cnt As Long ReDim v(1 To CLng(endDate) - CLng(startDate) + 1) For cnt = LBound(v) To UBound(v) v(cnt) = CDate(startDate) startDate = CDate(CDbl(startDate) + 1) Next cnt GetDates = v If IsArray(v) Then Erase v cnt = Empty End Function or Sub Test() Dim sDate As Date, eDate As Date, r As Long sDate = Range("D1").Value2 eDate = Range("F1").Value2 Range("D3:D" & Rows.Count).ClearContents Do Until sDate > eDate r = r + 1 Range("D" & r + 2).Value = sDate sDate = sDate + 1 Loop End Sub

ربما لو أرفقت ملفا به النتائج المتوقعة (الشكل النهائي للشيت) نتوصل بإذن الله لما تريد لأن المطلوب له أكثر من احتمال وأبسطها أن تكتب في أول خلية رأسية وليكن B3 =D1 ثم في الخلية التي تحتها B4 =IFERROR(IF(B3+1<=F$1,B3+1,""),"") مع سحب المعادلة لأسفل وتغيير تنسيق الخلايا إلى تاريخ بالتوفيق

للأسف نماذج الاكسل لا تدعم الارتباط التشعبي بالشكل المعتاد ولكن يمكن التحايل على ذلك بوضع عنوان الارتباط في label وتنسيق لون الخط أزرق وتحته خط وكأنه ارتباط واستعمال هذا الكود في حدث النقر على التسمية Private Sub lblLink_Click() ActiveWorkbook.FollowHyperlink Address:="mr-mas.com", NewWindow:=True Unload Me End Sub مع تغيير رابط موقعي إلى عنوان الارتباط التشعبي بالتوفيق

هذا ملفك بعد تنفيذ المطلوب التصفية بشرطين الفصل والنوع بالتوفيق قائمة فصل بنون وبنات.xlsx

الاستاذ محمد صالح سبحان الله وكانك تقرا ما بخاطري عندما قمت بتجربة كود الاستاذ ابراهيم جزاه الله خيرا حدث ما قلته بالضبط فظهرت الارقام معكوسة فقمت بحذف StrReverse حتى تظهر الارقام بصورتها الصحيحة فاذا بحضرتك تفيض علي من كرمك بحل رائع فجزاك الله خير الجزاء وزادك من فضله

جزاك الله خير الجزاء استاذ ايراهيم وجعله في ميزان حسناتك

يمكنك استعمال هذه المعادلة =IF(OR(Q6="",F6=""),"",IF(Q6>=250,"ناجح"&IF(F6="ذكر", "", "ة"),"له"&IF(F6="ذكر", "", "ا")&" برنامج علاجي")) بالتوفيق

السلام عليكم ورحمة الله استخدم الكود التالى Sub AbsCount() Dim ws As Worksheet, LR As Long Dim x As Long, y As Integer Dim C As Range, Abst As String Const Com = "," Set ws = Sheets("SS") x = 3 LR = ws.Range("AG" & Rows.Count).End(xlUp).Row Do While x <= LR For Each C In ws.Range("A" & x & ":AE" & x) If C.Value > 0 Then Abst = Abst & C.Value & Com ws.Range("AL" & x) = StrReverse(Left(Abst, Len(Abst) - 1)) End If Next C Abst = "" x = x + 1 Loop End Sub

كل الاصناف المضافة ضاهرة لدي .... اين تظهر معك المشكلة التي تتحدث عنها انظر .....

السلام عليكم ورحمة الله كنت أنتظر أن يقوم أحد الإخوة الكرام بإنشاء ماكرو للقيام بهذه العملية وهذا لم يكن، لهذا قمت بتحضير ما تريده في الملف المرفق باستعمال المعادلات... وللضرورة قمت بتغيير التنسيقات على الجداول وإضافة المعادلات المناسبة لعمل المطلوب (يرجى أن لا تقوم بحذف الصفوف أو الأعمدة لئلا تخسر المعادلات)... يبقى لتغييراتك أن تقوم بحجز فقط عدد المناصب -عدد الأساتذة- حسب المواد في "جدول 1" (جدول المواد) وعدد الأفواج -عدد الأقسام- حسب الشعبة والمستوى- في "جدول 2" (جدول الأقسام) والمعادلات تقوم باللازم لملء الجداول الأخرى (حتى الجدول 3 في ورقة Data)... والله أعلم... جدول ديناميكي.xlsx

Thank you very much for this trust. I am not expert, I am just a learner

أخي الكريم أبو حنين إليك التعديل التالي (لم أفهم طلبك الأخير ..كيف لا تحتوي ورقة العمل غير على خلية واحدة ..حاول تربط النقطة بخلية محددة تكون فارغة) Sub TransferToSpecificSheet() Dim Cell As Range, T As String, LR As Long, LRT As Long Dim WS As Worksheet, Answer As Long Set WS = Sheets("1") LR = WS.Cells(35, 3).End(xlUp).Row T = WS.Range("A3").Value Application.ScreenUpdating = False If Not IsEmpty(WS.Range("A3")) Then Range("B6:G" & LR).Copy With Sheets(T) LRT = .Cells(Rows.Count, 3).End(xlUp).Row + 1 .Cells(LRT, 2).PasteSpecial xlPasteValues End With Answer = MsgBox("هل تريد أن تمسح البيانات في ورقة 1 أم لا؟", vbYesNo + vbQuestion) If Answer = vbYes Then Sheets("1").Activate Sheets("1").Range("A3,C6:C35,F6:G35").Select Selection.ClearContents Else: End If Else MsgBox "الخلية المحددة فارغة لذا لن يتم تنفيذ الكود": Exit Sub End If Application.CutCopyMode = False Application.ScreenUpdating = True End Sub تقبل تحياتي