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

الحمد لله رب العالمين .... بالتوفيق

الحمد لله رب العالمين .... بالنوفيق

شغل النموذج Kanory ولاحظ الاستعلام الناتج -------->>>>>> 2132172302_FMARK_Kanory.mdb

اعمل لنا مثال مصغر وطبق الحماية عليه ... حتى نشوف مالذي يمكن فعله ...

برنامج القلعة النماذج منبثقة ومشروطة انظر >>>>>>>

تفضل ---------->>>>>> New تطبيق Microsoft Office Access.mdb

انظر انتهت المدة ولم استطع الدخول للبرنامج ..... فأين تكمن المشكلة ؟؟؟؟

.هذه طريقة اخرى بدون كتابة اسماء الحقول وخاصة عندما تكون كثيرة ولكن بشرط ان تتشابه ترتيب الحقول في الجدولين Dim db As DAO.Database Dim rstFrom As Recordset Dim rstTo As Recordset Set db = CurrentDb Dim RC, i, r As Integer Set rstTo = db.OpenRecordset("tblB1", dbOpenDynaset) Set rstFrom = db.OpenRecordset("tblB", dbOpenDynaset) rstFrom.MoveFirst: rstFrom.MoveLast RC = rstFrom.RecordCount rstFrom.MoveFirst For i = 1 To RC rstTo.AddNew For r = 1 To rstFrom.Fields.Count - 1 rstTo.Fields(r) = rstFrom.Fields(r) Next r rstTo.Update rstFrom.MoveNext Next i rstTo.Close rstFrom.Close Set rstTo = Nothing Set rstFrom = Nothing Set db = Nothing Kan_355.accdb

الكود يضيف كل السجلات الموجود في الجدول وذلك عن طريق الكود التالي RC = rstFrom.RecordCount rstFrom.MoveFirst For i = 1 To RC هذا الكود الذي انت وضعت جزءا منه لا يضيف كل الحقول الا اذا كتبت وحددت له الحقول بالشكل التالي rs.AddNew السطر التالي يعبر عن الحقل ..... قم بتكرار السطر بعدد الحقول الموجودة لديك rstTo!codhesab = rstFrom!codhesab rstTo!الحقل الثاني = rstFrom!الحقل الثاني وهكذا rs.Update أرفق لنا الجدولين وبه بيانات تجريبية للتطبيق

تفضل .... Dim db As DAO.Database Dim rstFrom As Recordset Dim rstTo As Recordset Set db = CurrentDb Dim RC, i As Integer Set rstTo = db.OpenRecordset("table2", dbOpenDynaset) Set rstFrom = db.OpenRecordset("table1", dbOpenDynaset) RC = rstFrom.RecordCount rstFrom.MoveFirst For i = 1 To RC rs.AddNew rstTo!codhesab = rstFrom!codhesab rs.Update rstFrom.MoveNext Next i rstTo.Close rstFrom.Close Set rstTo = Nothing Set rstFrom = Nothing Set db = Nothing

بإذن الله سيتم ايقاف الموقع لعدة ساعات مساء يوم الثلاثاء القادم الساعة العاشرة مساء بتوقيت القاهرة ، الحادية عشرة بتوقيت السعودية و ذلك لعمل ترقية لخادم قواعد البيانات

وعليكم السلام-لا يمكن عمل ما تريد ولكن يمكن كما تعلم مشاركة ملف الإكسيل لأكثر من شخص شرح مشاركة جدول اكسل للتعديل مع أكثر من شخص عن بعد Excel| انترنت أو شبكة داخلية

سنه واشهر وايام ام فقط اشهر وايام هل في النموذج أم تقرير ....... ؟؟؟؟؟ على كل حال جرب الوحدة النمطية هذه unction CalcAge(vDate1 As Date, vdate2 As Date) Dim vYears As Integer, vMonths As Integer, vDays As Integer vMonths = DateDiff("m", vDate1, vdate2) vDays = DateDiff("d", DateAdd("m", vMonths, vDate1), vdate2) If vDays < 0 Then vMonths = vMonths - 1 vDays = DateDiff("d", DateAdd("m", vMonths, vDate1), vdate2) End If vYears = vMonths \ 12 vMonths = vMonths Mod 12 CalcAge = vYears & "سنة, " & vMonths & "شهر, " & vDays & "يوم" End Functio استدعيها من خلال مربع النص هكذا Me.txtage.Text = CalcAge(Me.txtfrom, Me.txtto)

مشاركة مع أبي عارف .. عملت لك تنسيق شرطي بلون مغاير للرقم صفر .. test.accdb

قوائم.xlsm

الله عليك استاذنا الكبير(سليم) الف مليون تحيه وتقدير لحضرتك تم عمل كل المطلوب وبكفاءة عالية .... بفضل مجهودات حضرتك الحمدلله رب العالمين

تمام

هذا الأمر سيكون متروكاً للباحث، حيث يقوم بإنشاء الموضوع الذي يريده، وضمنه يضع أسماء الكتب التي يريدها، بنفس فكرة الاستبدال المتعدد، حيث هنالك يمكن إنشاء أي مجموعة، وضمنها توضع العبارات. شكراً لك أخي العزيز 🙂

تمام، ومن المهم أن يكون هناك ترتيب حسب الموضوعات، يعني مثلا: التفسير وعلومه، كتب الحديث، كتب الفقه، كتب اللغة، كتب الأدب، المعاجم، كتب النحو والصرف والعروض، ... إلخ. وبالتوفيق دائما.

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

استخدم الحماية ... بحيث لا يعمل البرنامج سوى الاجهزة التى تريدها فقط

اعد تحمبل الملف من جديد لأنه ظهر هناك خطأ بسيط في معاينة الطباعة (تم اصلاحه) الخطأ يكمن في ان الطباعة تتم ابتداء من الصف السادس بينما المطلوب ان تتم ابتداء من الصف الأول وذلك باستبدال الرقم 6 بالرقم 1 قي هذا السطر Range("A6:J31").Address

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

تم ادراج صفحة للعمل بواسطة المعادلات " Section_1 " تم معالجة الأمر بالنسبة للطباعة الزر "Show hidden Rows" يظهر لك الصفوف المخفية (فارغة) الماكرو يظهر لك معاينة قبل الطباعة رز " معاينة الطباعة " لاستبدال الامر الى الطباعة المباشرة غير السطر (الثالث من اخر الماكرو الأول) و لا تنس كتابة النقطة قبله من PrintPreview الى PrintOut Option Explicit Sub Print_areas() Dim Mx1%, Mx2%, Mx Show_rows If ActiveSheet.Name = "main" Then Exit Sub With ActiveSheet Mx1 = Application.Max(Range("A6:A30")) + 5 Mx2 = Application.Max(Range("F6:F30")) + 5 Mx = Application.Max(Mx1, Mx2) + 1 .Range("A" & Mx & ":A" & 30).EntireRow.Hidden = True .PageSetup.PrintArea = .Range("A1:J31").Address .PrintPreview End With End Sub '++++++++++++++++++++++++++++ Sub Show_rows() If ActiveSheet.Name = "main" Then Exit Sub ActiveSheet.Range("A6:A30").EntireRow.Hidden = False End Sub الملف من جديد Abou_malak_new.xlsm

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

هذا أمر طبيعى ومنطقى بأن يطلب كلمة المرور عند فتح الملف كل مرة .... فلا يمكن عمل الإستثناء الذى تريده الا عند الغاء كلمة المرور نهائياً , وشكراً

_البرنامج 1-7-2020 - نسخة.xls

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

جرب هذا الماكرو تم تعديل القوائم المنسدلة في الشيت fasl و الشيت fasl2 النطاق "K1" ليتناسب مع كل الاحنمالات في الشيت main الزر All In One1 يعمل الفلترة وينقلها الى كل شيت بمفردها في الشيت fasl و الشيت fasl2 الزر استدعاء يتفذ الماكرو الخاص بكل منهما (مع الترقيم اوتوماتيكي بدون معادلات لتصغير حجم الملف من جهة و من جهة احرى لعدم العبث بالمعادلات اذا وجدت عن طربق الحطأ ) Option Explicit Private M As Worksheet Private F1 As Worksheet Private F2 As Worksheet Private LM%, LF1%, LF2% Private M_rg As Range, F1_rg As Range Private F2_rg As Range Private Filter_range As Range Private Cret1$, Cret2$ Private cont Private y% '++++++++++++++++++++++++++++++ Sub Get_all() My_filter_forF1 My_filter_forF2 End Sub Sub My_filter_forF1() With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With First_Macro On Error Resume Next F1.Range("A6:J30").ClearContents Set Filter_range = F1.Range("k1") If M.AutoFilterMode Then M.Range("A3").AutoFilter M_rg.AutoFilter 5, Filter_range M_rg.AutoFilter 7, Cret1 M.Range("B4:B" & LM).SpecialCells(12).Copy F1.Range("B6").PasteSpecial (12) M.Range("G4:G" & LM).SpecialCells(12).Copy F1.Range("C6").PasteSpecial (12) M.Range("H4:H" & LM).SpecialCells(12).Copy F1.Range("D6").PasteSpecial (12) M.Range("I4:I" & LM).SpecialCells(12).Copy F1.Range("E6").PasteSpecial (12) cont = Application.CountA(F1.Range("B6:B25")) If cont > 0 Then F1.Range("A6").Resize(cont) = _ Evaluate("ROW(1:" & cont & ")") End If M_rg.AutoFilter 7, Cret2 M.Range("B4:B" & LM).SpecialCells(12).Copy F1.Range("G6").PasteSpecial (12) M.Range("G4:G" & LM).SpecialCells(12).Copy F1.Range("H6").PasteSpecial (12) M.Range("H4:H" & LM).SpecialCells(12).Copy F1.Range("I6").PasteSpecial (12) M.Range("I4:I" & LM).SpecialCells(12).Copy F1.Range("J6").PasteSpecial (12) cont = Application.CountA(F1.Range("G6:G25")) If cont > 0 Then F1.Range("F6").Resize(cont) = _ Evaluate("ROW(1:" & cont & ")") End If If M.AutoFilterMode Then M.Range("A3").AutoFilter On Error GoTo 0 With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With End Sub '+++++++++++++++++++++++++++++++++++++ Sub My_filter_forF2() With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With First_Macro On Error Resume Next F2.Range("A6:J30").ClearContents Set Filter_range = F2.Range("k1") If M.AutoFilterMode Then M.Range("A3").AutoFilter M_rg.AutoFilter 5, Filter_range M_rg.AutoFilter 7, Cret1 M.Range("B4:B" & LM).SpecialCells(12).Copy F2.Range("B6").PasteSpecial (12) M.Range("G4:G" & LM).SpecialCells(12).Copy F2.Range("C6").PasteSpecial (12) M.Range("H4:H" & LM).SpecialCells(12).Copy F2.Range("D6").PasteSpecial (12) M.Range("I4:I" & LM).SpecialCells(12).Copy F2.Range("E6").PasteSpecial (12) cont = Application.CountA(F2.Range("B6:B25")) If cont > 0 Then F2.Range("A6").Resize(cont) = _ Evaluate("ROW(1:" & cont & ")") End If M_rg.AutoFilter 7, Cret2 M.Range("B4:B" & LM).SpecialCells(12).Copy F2.Range("G6").PasteSpecial (12) M.Range("G4:G" & LM).SpecialCells(12).Copy F2.Range("H6").PasteSpecial (12) M.Range("H4:H" & LM).SpecialCells(12).Copy F2.Range("I6").PasteSpecial (12) M.Range("I4:I" & LM).SpecialCells(12).Copy F2.Range("J6").PasteSpecial (12) cont = Application.CountA(F2.Range("G6:G25")) If cont > 0 Then F2.Range("F6").Resize(cont) = _ Evaluate("ROW(1:" & cont & ")") End If If M.AutoFilterMode Then M.Range("A3").AutoFilter On Error GoTo 0 With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With End Sub ''++++++++++++++++++++++++++++++ Sub First_Macro() Set M = Sheets("main") Set F1 = Sheets("fasl") Set F2 = Sheets("fasl2") LM = M.Cells(Rows.Count, 2).End(3).Row LF1 = F1.Cells(Rows.Count, 1).End(3).Row If LF1 < 6 Then LF1 = 6 LF2 = F2.Cells(Rows.Count, 1).End(3).Row If LF2 < 6 Then LF2 = 6 Set M_rg = M.Range("A3:I" & LM) Set F1_rg = F1.Range("A6:J30") Set F2_rg = F2.Range("A6:J30") Cret1 = "ذكر": Cret2 = "أنثى" End Sub الملف مرفق Abou_malak.xlsm

اتفضل لعله يفى بالغرض فى شيت fasl2 عند الاختيار من القائمة المنسدلة الفصل يجلب لك اسماء الطلاب ولغيت لك زر استدعاء الطلاب Copy of قوائم.xlsm

اشكرك و الشكر مستحق +1

تفضل با صديقي AB_Shraf.xlsm

Try This Macro Option Explicit Sub Colorize_Comments() Const CLR = 35 With Range("A1").CurrentRegion .Interior.ColorIndex = xlNone .SpecialCells(1).Interior.ColorIndex = CLR End With End Sub

انسخ الشفرة التالية وضعها في حدث عند النقر لزر الأمر Dim DB As DAO.Database Set DB = CurrentDb() '--- DB.Execute "SELECT * INTO [عناوين المرضى] IN'" _ & CurrentProject.Path & "\Patients.xlsx'[Excel 12.0;HDR=yes;READONLY=FALSE] FROM TABLE1 " '--- DB.Execute "SELECT * INTO [حالة العلاج] IN'" _ & CurrentProject.Path & "\Patients.xlsx'[Excel 12.0;HDR=yes;READONLY=FALSE] FROM TABLE2 "

حياك الله وبالتوفيق ,,,,,

تفضل اخي سالم test.rar

بسيطة استبدل الكود بهذا الكود Sub test() Dim a As Variant Dim m As Object Dim r, i r = ActiveSheet.Cells(Rows.Count, 3).End(xlUp).Row With CreateObject("VBScript.RegExp") .Global = True .Pattern = "(\d.*\d)" For i = 2 To r Set m = .Execute(Cells(i, 3)) a = Split(m(0), "*") Cells(i, 3).Offset(, 1) = a(0) * a(1) Next End With End Sub سليم (2).xlsm

عليكم السلام Private Sub endpage_Click() strSql = "SELECT * FROM tblData WHERE tblData.ID > ( (select COUNT(*) from tblData) - 10)" Me.RecordSource = strSql End Sub Private Sub firstpage_Click() strSql = "SELECT TOP 10 tblData.ID, tblData.[NO], tblData.Locatin, tblData.SecName, tblData.DepName, tblData.RegDate FROM tblData WHERE (((tblData.ID)>=1))" Me.RecordSource = strSql End Sub السجلات في النموذج .mdb

بالخدمة استاذ أبو يحيى الجبلاوي تصميم صندوق-2.rar

كشف 12 للصف السادس الابتدائي ------------------------------------------------------ ------------------------------------------------------ ------------------------------------------------------ https://cutt.ly/thychh

مشاركة مع حبيبنا الاستاذ . حسام استبدل الكود بهذا >>>>>> If Me.m1.ListCount = 0 Then Me.m1.AddItem "م" & ";" & "الصنف" & ";" & "عدد" & ";" & "المبلغ" Me.m1.AddItem Me.id & ";" & Me.tex_snf & ";" & Me.tex_count & ";" & Me.tex_ammount Else Me.m1.AddItem Me.id & ";" & Me.tex_snf & ";" & Me.tex_count & ";" & Me.tex_ammount End If Dim i As Long, SumTotal As Long SumTotal = 0 For i = 1 To (Me.m1.ListCount - 1) SumTotal = SumTotal + Nz(Me.m1.ItemData(i), 0) Next i txtTotal = SumTotal

أعمال ممتازة استاذ أحمد جزاك الله كل خير

كان وضعت مثال للتطبيق .... على كل حال جرب الكود التالي .... أو ارفق ملفك للتعديل . On Error Resume Next If IsNull(Me.readtbl.Column(0)) Then MsgBox "The List Empty or Items in list not selected", vbCritical, "Caution" Exit Sub End If Me.ProgBar.Visible = True Dim x As Integer For x = x To 30000 Me.ProgBar.Value = x If x = 30000 Then Me.ProgBar.Visible = False End If Next x Dim i As Integer Dim tbl As String Dim SDest As String Dim SFileName As String SDest = Me.txtPath SFileName = Me.txtFileName For i = 0 To Me.readtbl.ListCount - 1 If Me.readtbl.Selected(i) = True Then tbl = Me.readtbl.Column(0, i) DoCmd.TransferSpreadsheet acExport, , tbl, SDest & "\" & SFileName & ".xlsx" End If Next i MsgBox "تم بحمد الله الانتهاء من عملية التصدير ", 0 + 64 + 1572864, "مبروك"

تفضل اخ طاهر الوليدي ارجو ان يكون طلبك Root1010.rar

بارك الله فيك استاذ محي ولإثراء الموضوع يمكنك استخدام هذه المعادلة المعرفة وهذا هو كودها Function Evals(t As String) As Double Dim c As String, i As Long For i = 1 To Len(t) If Asc(Mid(t, i, 1)) < 58 And Asc(Mid(t, i, 1)) > 41 Then c = c & Mid(t, i, 1) Next Evals = Evaluate(c) End Function ثم تكتب المعادلة بالخلية B2 على النحو التالى : =Evals(A2) سليم1.xlsm

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

وهذه مشاركة مع الاستاذ. @Shivan Rekany >>>>>>> Kan_324.accdb

تفضل هذا الكود شامل الشرح اخي الكريم On Error GoTo errorhandle Dim MyFilePath, MyRange, MyTablName As String 'MyFilePath = "مسار ملف الاكسل" MyRange = "نطاق الخلايا المراد استيرادها من ملف الاكسل" MyTablName = "اسم الجدول الذي سيتم تخزين البياناته به" '-------------------------------- '''''''' فتح مستعرض الملفات لإختيار الملف '''''''' Dim fpath As Variant With Application.FileDialog(3) .Title = "Choose File" .Filters.Clear .Filters.Add "Excel Files", "*.xls ; *.xlsx" .AllowMultiSelect = False .InitialFileName = "" If .Show = -1 Then MyFilePath = .SelectedItems(1) End If End With '-------------------------------- '''''''' استيراد ملف الاكسل حسب الشروط اعلاه '''''''' DoCmd.TransferSpreadsheet acImport, 10, MyTablName, FilePath, False, MyRange MsgBox "تم استيراد الملف بنجاح", vbMsgBoxRight + vbInformation, "تأكيد" errorhandleexit: Exit Sub errorhandle: MsgBox Err.Description Resume errorhandleexit

حيث أنك لم ترقع ملف للمعاينة جرب هذا الملف Fuction_split_name.xlsm

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