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

تفضل إضافة و حذف مرفقات.rar

السلام عليكم عودة ميمونة أخي أبا جودي إليك كود إضافة المرفقات لجدول: On Error Resume Next DoCmd.Save Dim i As Integer Dim txtpath As String Dim rsPictures Dim db As DAO.Database Dim rsEmployees As DAO.Recordset 'Dim rsPictures As DAO.Field i = CurrentRecord - 1 With Application.FileDialog(1) .AllowMultiSelect = False .Title = "ÇÎÊÑ ãßÇä ÇáÍÝÙ" If .Show = -1 Then txtpath = .SelectedItems.Item(1) End If End With '------------------------------------------ Set db = CurrentDb Set rsEmployees = db.OpenRecordset("tbl") rsEmployees.Move (i) rsEmployees.Edit Set rsPictures = rsEmployees.Fields("attach1").Value rsPictures.AddNew rsPictures.Fields("FileData").LoadFromFile txtpath rsPictures.Update rsEmployees.Update Set rsEmployees = Nothing Set rsPictures = Nothing Me.Refresh و هذا كود الحذف: On Error Resume Next DoCmd.Save Dim i As Integer Dim txtpath As String Dim rsPictures Dim db As DAO.Database Dim rsEmployees As DAO.Recordset i = CurrentRecord - 1 '------------------------------------------ Set db = CurrentDb Set rsEmployees = db.OpenRecordset("tbl") rsEmployees.Move (i) rsEmployees.Edit Set rsPictures = rsEmployees.Fields("attach1").Value rsPictures.Delete rsEmployees.Update Set rsEmployees = Nothing Set rsPictures = Nothing Me.Refresh مع العلم أن tbl هو اسم الجدول و attach1 هو اسم الحقل و هذا مرفق للتوضيح. attach.rar

جرب المرفق 123.accdb Private Sub n_AfterUpdate() If IsNumeric([n]) Then m = 0 Else m = 20 End If End Sub

السلام عليكم و رحمة الله و بركاته الملف منقول للأمانة لأحد الاخوة , يحتوي على نموذج به أزرار جميلة قد يستفاد منه في تصميم البرامج ازرار.rar

العفو أخي وفقك الله إلى ما يحبه و يرضاه إن شاء الله

وهذا ما تريده على مرفق استاذى الحبيب واخى الاستاذ @صالح حمادي ولكن لم اضف ال gif لانها لن تتحرك إضافة و حذف مرفقات.accdb

جرب هذا التعديل attach.rar

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

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

@kha9009lid جزاك الله كل خير .. نعم هذا هو المطلوب شكرآ جزيلآ لك @ابا جودى وفقك الله و حقق ما في بالك شكرى جزيلآ لك تمت الإجابة و لله الحمد

طبعا استاذى الجليل واخى الجبيب والعزيز على قلبى الاستاذ @Barna جزاه الله خيـــر كفى ووفى وإثراء للموضوع اضف هذا المرفق - اختزال كامل وشامل لكود حساب العمر - الحساب مباشرة داخل النموذج بمجرد وضع التاريخين - عدم اضافة اى بيانات داخل الجدول نتيجة لاحتساب العمر فقط يحتسب العمر من الدالة داخل الموديول ومن خلال الاستعلام دفعة واحدة لاى عدد من السجلات مهما كان الفرق بين تاريخين.mdb

طبعا كل اساتذتى الكرام واخوانى الاحباب كفوا ووفوا جزاهم الله خيرا ومساهمة من العبد الفقيـر الى الله هذا المرفق للاستاذى الجليل ومعلمى القدير الاستاذ @أبو آدم جمال المرفق فى انه ان وجدت اكثر من طابعة يمكن فى كل مرة اختيار احداهم بكل يسر ومرونة NA_ReportPrenter.mdb

وتيسيرا على احبابى الاستاذ @محمد صلاح1 و الاستاذ @عبد اللطيف سلوم هذا مثال عملى getMacAddress.mdb

لا شكر على واجب استاذي الكريم @صالح حمادي

وذلك تعديل جديد لعرض الشعار فى كل زوايا القاعدة imgLogo.Picture = MyLogo() على ان يتم استبدل كلمة imgLogo باسم عنصر التحكم الخاص بالصورة كما تسميه انت Logo Company (Up 3).mdb

تفضل الأمر سهل وبسيط يمكنك مشاهدة هذا الفيديو https://www.youtube.com/watch?v=JOGUVtuJAQ4

أحبك الله الذي أحببتني له

واثراء للموضوع طالما سبقنى استاذى الجليل الاستاذ @صالح حمادي هذه فكرة على طريقة استاذى الجليل ومعلمى القدير الاستاذ @jjafferr حمل الصورة داخل القاعدة وليس مرفق والقاعدة المرفقة بتنسيق 2003 افتح القاعدة فى مجلد فارغ ولاحظ وجود الشعار فى النموذج اذهب للمجلد الذى وضعت به القاعدة تجد مجلدات تم اضافتها وبداخلها الشعار امسح الشعار وقم باغلاق وفتح القاعدة وشاهد السحر قم بتغيير الشعار مهما كان اسمه ومهما كانت صيغة الملف jpg . png bmp ارجع الى المجلدات تجد الشعار الجديد وحذف القديم واستبداله داخل القاعدة مهما كان اسم الشعار دون ادنى تدخل من المستخدم Logo Company.mdb اعتذر للتأخير كان وقت الصلاة

السلام عليكم جرب المرفق اضغط فوق الزر الأحمر بالزر اليمين للفأرة سوف تظهر لك قائمة بها ثلاثة عناصر كل عنصر له أمر معين تستطيع التعديل على الأوامر و المسميات من الوحدة النمطية و وحدات الماكرو الكود.rar

نورت الدنيا كلها استاذنا وحبيبنا @ابا جودى

فكرة رقم ( 2 ) 123-up (2).accdb

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

وهذا المرفق ايضا اثراء للموضوع وللامانه لا اذكر من اين حصلته لكن قمت ببعض التعديلات التى تتماشى مع افكارى ومتطلباتى ولكنه يتيح تحكم اشمل واعم من المرفق السابق Full Control Of Print Report.accdb

تم التعديل على الملف المرفق سابقا للمرة الثانية

جربي المرفق قاعده ادخال البيانات (3).xlsm

نعمل صفحة ونسيمها قائمة ومنها عند تغير الصفحة تفتح صفحة جديدة بدل الفورم ثم نفتح قائمة منسدلة فى الصفحة الرئيسية الى عليها الشغل لما يحصل تغير فى الصفحة يدور على اسم الصفحة مع الاسم فى العموود ويرحل البيانات مدة مش محتاجين اى فورم وبهذا وفرت وقت ومجهود واتمنى ان الفكرة تعجب الاساتذة

تم اضافة 3 مخازن كل منها يحتوى على تصنيفات 3 (5).accdb

أخي @المهاجر ابو معاذ قم بنسخ المحدد كما بالصور .. الى ملفك الذي تريد وضع هذه الاكواد كالتالي: تحت زر ضع كود فتح التقرير DoCmd.OpenReport "rpt_rensen", acViewPreview salah_hommadi و في التقرير حدث عند التحميل DoCmd.Maximize change_font (Me.Name)

اخي على ما فهمت من مشاركتك تريد انشاء صفحة لكل "كود محاسبي" وترحيل بياناته حسب الشرط ، والشرط هنا هو "كود محاسبي" عموما لنفهم موضوعك أكثر قم بوضع نمودج لطلبك وارسله مرة اخرى وهكذا يمكن مساعدتك ان شاء الله او انظر المرفق وضعت شيتين كنمودج ان كان ما تريد فهذا سيساعد الاساتذة على العمل في طلبك الصندوق2019.xlsm

x = Application.Match(Val(Application.Max(ws.Columns(1))), ws.Columns(1), 0) If Not IsError(x) Then tbID = ws.Cells(x + 1, 2).Value '============================================== x = Application.Match(Val(Application.Max(ws.Columns(1))), ws.Columns(1), 0) If Not IsError(x) Then tbID = ws.Cells(x + 1, 2).Value استاذة OmHamza قلت ان الرقم المدني يعمل تلقائي سابقا ولكن في الواقع لن يعمل كما هو موضح في الكود المخصص لهذه الوضيفة علما ان العمود في صفحة العمل هو (B) عموما انا تركته كما في مشاركتك الاولى وهو كما ترين في الاسطر اعلاه. اما بالنسبة لكمبوبوكس "الشارع" تم اضافته في الفورم انظري المرفق تحياتي قاعده ادخال البيانات.xlsm

هذا الكود يفي بالغرض ان شاء الله (تم تغيير اسماء الصفحات لنسخ الكود بشكل جيد وعدم الوقوع في مشاكل اللغة حيث تظهر حروف غير معروفة عند البعض) Option Explicit Sub AnyThing() Dim lastrow_1 As Long, counter As Long Dim lastrow_2 As Long, key As Variant Dim sh1 As Worksheet, sh2 As Worksheet Dim rng1, rng2 As Range, p As Variant Dim dict As Object Set sh1 = Sheets("SH1") Set sh2 = Sheets("SH2") sh2.Range("I3").Resize(1000, 3).ClearContents lastrow_1 = sh1.Cells(sh1.Rows.Count, "B").End(3).Row lastrow_2 = sh1.Cells(sh2.Rows.Count, "B").End(3).Row Set rng1 = sh1.Range("A3:D" & lastrow_1) Set rng2 = sh2.Range("A3:D" & lastrow_2) Set dict = CreateObject("Scripting.Dictionary") For Each p In rng1.Columns(2).Cells If Not dict.Exists(p.Value & "," & p.Offset(, 1)) Then dict.Add p.Value & "," & p.Offset(, 1), p.Offset(, 2) Else dict(p.Value & "," & p.Offset(, 1)) = _ dict(p.Value & "," & p.Offset(, 1)) + p.Offset(, 2) End If Next p '=============================== For Each p In rng2.Columns(2).Cells If Not dict.Exists(p.Value & "," & p.Offset(, 1)) Then dict.Add p.Value & "," & p.Offset(, 1), p.Offset(, 2) Else dict(p.Value & "," & p.Offset(, 1)) = _ dict(p.Value & "," & p.Offset(, 1)) + p.Offset(, 2) End If Next p '============================== counter = 2 With sh2 For Each key In dict.Keys counter = counter + 1 .Cells(counter, "I").Resize(1, 2) = Split(key, ",") .Cells(counter, "K") = dict(key) Next key End With dict.RemoveAll: Set dict = Nothing Set sh1 = Nothing: Set sh2 = Nothing Set rng1 = Nothing: Set rng2 = Nothing End Sub الملف المرفق Total.xlsm

نصيحة مني لك عن تجربة ... أبداء بانشاء الملف وارفقه في موضوعك .. حينها ستجد هنا من يساعدك

اخي الكريم للطباعة مباشرة DoCmd.OpenReport "اسم التقرير" و من طريقة عرض التصميم للتقرير اذهب الى اعدادات الصفحة و اتبع التالي لتحديد الطابعة

بعد ادن الاستادأحمد يوسف تفضل جرب المرفق مخزن الأثاث.xlsm

بارك الله بك اخي مصطفى وهذا عمل اخر يقوم بنفس الشيء لكن بدالة معرفة UDF الكود بداية Option Explicit Function Salim_Split_Name(N_name, n) Dim x% Dim arr: arr = _ Array("سيف", "عبد", "أبو", "ابو", "عز", _ "صدر", "نور", "فضل") '++++++++++++++++++++++++++++++++++++++ Rem Array تستطيع ان تضيف اي بداية اسم مركب داخل هذا الــ '+++++++++++++++++++++++++++++++++++++ Dim My_Col As New Collection Dim Final_col As New Collection Dim it, my_st, my_name my_st = Trim(N_name) my_name = Split(Trim(my_st)) For x = LBound(my_name) To UBound(my_name) My_Col.Add my_name(x) Next x For x = 1 To My_Col.Count If Not (IsError(Application.Match(My_Col(x), arr, 0))) Then Final_col.Add My_Col(x) & " " & My_Col(x + 1) x = x + 1 Else Final_col.Add My_Col(x) End If Next x If n > Final_col.Count Then Salim_Split_Name = "" Else Salim_Split_Name = Final_col(n) End If Set My_Col = Nothing: Set Final_col = Nothing Erase arr End Function نموذج عن الدالة وكيفية عملها في الملف المرفق Fuction_split_name.xlsm

جزاك الله كل خير أستاذ سليم عمل رائع ولإثراء الموضوع بعد اذن حضرتك هذا حل اخر بالمعادلات العادية فإذا كان مثلا الرقم القومى موجود بالخلية A2 فيمكنك استخدام هذه المعادلة مع السحب بباقى الأعمدة =MID($A2,COLUMN(A2),1) الرقم القومي.xlsx

أخى الكريم محمد انا قلت لك سابقا ربما هناك مشكلة معى مع ملفك فلا اعلم ما هو سبب عدم استطاعتى وضع اى كود فى ملفك لذلك ارسلت لك هذا الرابط من داخل المنتدى ربما يفيد طلبك كثيرا https://www.officena.net/ib/topic/59928-شاشة-دخول-مع-صلاحيات/

وعليكم السلام تفضل-يمكنك تجربة هذه الأكواد طالما انك لم ترفع ملف Private Sub UserForm_Initialize() TextBox1.Text = "" End Sub Private Sub CommandButton1_Click() TextBox1.Text = "Sid" MsgBox "Re-Initialzing the Userform" UserForm_Initialize End Sub Private Sub UserForm_Initialize() ChartNum = 1 UpdateChart_OverallOEE UpdateChart_OverallUnits UpdateChart_OverallWeights End Sub Private Sub UpdateChart_OverallOEE() Set CurrentChart = Sheets("Chart_OverallOEE").ChartObjects(ChartNum).Chart CurrentChart.Parent.Width = 710 CurrentChart.Parent.Height = 150 ' Save chart as GIF Fname = ThisWorkbook.Path & Application.PathSeparator & "Chart_OverallOEE.gif" CurrentChart.Export Filename:=Fname, FilterName:="GIF" ' Show the chart img_Chart_OverallOEE.Picture = LoadPicture(Fname) End Sub Private Sub UpdateChart_OverallUnits() Set CurrentChart = Sheets("Chart_OverallUnits").ChartObjects(ChartNum).Chart CurrentChart.Parent.Width = 700 CurrentChart.Parent.Height = 150 ' Save chart as GIF Fname = ThisWorkbook.Path & Application.PathSeparator & "Chart_OverallUnits.gif" CurrentChart.Export Filename:=Fname, FilterName:="GIF" ' Show the chart img_Chart_OverallUnits.Picture = LoadPicture(Fname) End Sub Private Sub UpdateChart_OverallWeights() Set CurrentChart = Sheets("Chart_OverallWeights").ChartObjects(ChartNum).Chart CurrentChart.Parent.Width = 700 CurrentChart.Parent.Height = 175 ' Save chart as GIF Fname = ThisWorkbook.Path & Application.PathSeparator & "Chart_OverallWeights.gif" CurrentChart.Export Filename:=Fname, FilterName:="GIF" ' Show the chart img_Chart_OverallWeights.Picture = LoadPicture(Fname) End Sub

تفضل index2.xlsm

وعليكم السلام كان عليك من البداية استخدام خاصية البحث فى المنتدى تفضل https://www.officena.net/ib/topic/87818-استفسار-عن-طريقة-اضافة-اكثر-من-مستخدم/?tab=comments#comment-555050

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

عليك برفع ملف وشرح المطلوب عليه بالتفصيل

وعليكم السلام -اهلا بك فى المنتدى طالما انك لم تقم برفع ملف فهناك العديد من الطرق منها : يمكنك مشاهدة هذا الفيديو https://www.youtube.com/watch?v=nF1VNTGzN3c https://www.youtube.com/watch?v=qU1z3jdUZ_g وهذا ايضا رابط للتحويل مباشرة من الوورد الى الإكسيل https://convertio.co/ar/doc-xls/ وهذه طريقة سهلة لتحويل ملفات الورد لإكسيل دون الحاجه لبرامج تحويل الملفات 1- إفتح ملف الورد المراد تحويله لإكسيل word .doc 2- قم بحفظة على صورة ملف بصيغة اتش تي ام ال أو صفحة إنترنت باسم الملف المراد تحويلة file / save as / web page format 3 – قم بفتح ملف اكسيل جديد open new xls 4- اضغط على فتح في قائمة ملف open /brwos/ select file 5- إختار الملف بصيغة الاتش تي ام ال السابق تحويله file html. 6- قم بحفظ الملف ذاته بأختيار صيغة اكسيل ورقة عمل باختيار احد صيغ الأكسيل باصداراته المراد انشاؤها file/ save as/ xls 97/2033 وهذا رابط اخر من داخل المنتدى ناقش نفس الموضوع https://www.officena.net/ib/topic/33342-المطلوب-ملف-وورد-به-جداول-طولية-تحويله-الى-ملف-اكسل/ وهذه فيديوهات كمان لنقل البيانات من الوورد الى الإكسيل بأكواد VBA : https://www.youtube.com/watch?v=9QJXmsczaP8 https://www.youtube.com/watch?v=5IRWMSBmw1w وهذا كود تحويل ايضا Sub importTableDataWord() ‘We declare object variables for Word Application and document Dim WdApp As Object, wddoc As Object ‘Declare a string variable to access our Word document Dim strDocName As String ‘Error handling On Error Resume Next ‘Activate Word it is already open Set WdApp = GetObject(, “Word.Application”) If Err.Number = 429 Then Err.Clear ‘Create a Word application if Word is not already open Set WdApp = CreateObject(“Word.Application”) End If WdApp.Visible = True strDocName = “C:\our-inventory\inventory.docx” ‘Check relevant directory for relevant document ‘If not found then inform the user and close program If Dir(strDocName) = “” Then MsgBox “The file ” & strDocName & vbCrLf & _ “was not found in the folder path” & vbCrLf & _ “C:\our-inventory\.”, _ vbExclamation, _ “Sorry, that document name does not exist.” Exit Sub End If WdApp.Activate Set wddoc = WdApp.Documents(strDocName) If wddoc Is Nothing Then Set wddoc = WdApp.Documents.Open(strDocName) wddoc.Activate ‘define variables to access the tables in the word document Dim Tble As Integer Dim rowWd As Long Dim colWd As Integer Dim x As Long, y As Long x = 1 y = 1 With wddoc Tble = wddoc.tables.Count If Tble = 0 Then MsgBox “No Tables found in the Word document”, vbExclamation, “No Tables to Import” Exit Sub End If ‘start the looping process to access tables and their rows, columns For i = 1 To Tble With .tables(i) For rowWd = 1 To .Rows.Count For colWd = 1 To .Columns.Count Cells(x, y) = WorksheetFunction.Clean(.cell(rowWd, colWd).Range.Text) ‘Access next column y = y + 1 Next colWd ‘go to next row and start from column 1 y = 1 x = x + 1 Next rowWd End With Next End With ‘we don’t need to save the word document wddoc.Close Savechanges:=False ‘we quit Word WdApp.Quit ‘We finally release system memory allocated to the 2 object variables Set wddoc = Nothing Set WdApp = Nothing End Sub

هذا هو الملف -كان عليك اخى الكريم رفع الملف لكى تتم الإستفادة للجميع ان شاء الله الشهيدة نهال العقيد.xlsm

تفضل المصنف100.xlsm

يجب عليك ضبط لغة جهازك وذلك من خلال الشرح الموجود على هذا الرابط https://www.officena.net/ib/topic/87988-اللغه-العربيه-في-الاكسيل-2010-لا-تظهر-بشكل-صحيح/?tab=comments#comment-556696

عليك برفع الملف حتى تتم المساعدة

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

قد تم التعديل من قبل استاذنا الكبير ابراهيم الحداد فى المشاركة الأخرى له منا جميعا كل المحبة والإحترام Sub DatedIf_User() Dim ws As Worksheet, Sh As Worksheet, Mh As Worksheet Dim ShName As String, Rng As Range, C As Range Dim LR As Long, VlDate As Variant Application.ScreenUpdating = False Set ws = Sheets("بيانات الطالبات") VlDate = ws.Range("I5").Value '---------------------------------- LR = ws.Cells(Rows.Count, "E").End(xlUp).Row If LR < 8 Then Exit Sub ws.Range("I8:K" & LR + 1).ClearContents Set Rng = ws.Range("H8:H" & LR) '---------------------------------- If IsEmpty(VlDate) = True Then MsgBox "من فضلك ادخل تاريخ حساب السن" Exit Sub Else On Error Resume Next For Each C In Rng If C.Value <> "" Then YY = Year(VlDate) y = Year(C.Value) mm = Month(VlDate) m = Month(C.Value) dd = Day(VlDate) D = Day(C.Value) '----------------------- If D > dd And m > mm Then C.Offset(0, 1) = dd + 30 - D C.Offset(0, 2) = mm - m + 11 C.Offset(0, 3) = YY - y - 1 '----------------------- ElseIf D <= dd And m > mm Then C.Offset(0, 1) = dd - D C.Offset(0, 2) = mm - m + 12 C.Offset(0, 3) = YY - y - 1 '----------------------- ElseIf D >= dd And m = mm Then C.Offset(0, 1) = dd - D + 30 C.Offset(0, 2) = mm - m + 11 C.Offset(0, 3) = YY - y - 1 '----------------------- ElseIf D >= dd And m < mm Then C.Offset(0, 1) = dd - D + 30 C.Offset(0, 2) = mm - m - 1 C.Offset(0, 3) = YY - y '----------------------- Else C.Offset(0, 1) = dd - D C.Offset(0, 2) = mm - m C.Offset(0, 3) = YY - y End If End If Next End If Application.ScreenUpdating = True End Sub

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