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

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

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

شغل النموذج 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

السلام عليكم ورحمة الله وبركاته الأخ الحبيب أبو عاصم، حياك الله، وبعد: أولاً: تم تنفيذ اقتراحك بإضافة ميزة (استيراد - تصدير) إلى نافذة الاستبدال المتعدد، وتم نشر التحديث الجديد 3.9.0.0. [الجديد في التحديث 3.90]: في نافذة استبدال متعدد، تم إضافة خاصيتين جديدتين: 1- تصدير: يمكنك من خلال هذه الخاصية تصدير عبارات مجموعة ما إلى مستند نصي. 2- استيراد: هذه الخاصية عكس الخاصية السابقة، حيث تسمح لك باستيراد عبارات من ملف نصي إلى المجموعة المختارة، مع الانتباه إلى أن العبارات المكررة سيتم استثناؤها من عملية الاستيراد، وضمن الملف النصي تكتب العبارة الخاطئة والصحيحة ضمن سطر بهذا التنسيق: العبارة الخاطئة[=]العبارة الصحيحة، وهو نفس التنسيق الذي يتم من خلال الخاصية السابقة. التحميل: https://www.shhada.net/contents/downloadsm/4MAEgubYzqynkm6y.zip ثانياً: أنت محق بخصوص ما ذكرته عن (فهرس المصادر والمراجع). بالحقيقة أفكر بإضافة هذه الخاصية بشكل احترافي، يلبي كافة الخيارات التي يريدها الباحث أو التي تعتمدها الجامعات. تصوري للموضوع على النحو الآتي: 1- تبويب الإضافة والتحرير: اسم الكتاب، اسم المؤلف، لقب المؤلف، المحقق، دار النشر، بلد النشر، رقم الطبعة، تاريخ الطبعة. مثلاً: الإتقان في علوم القرآن، جلال الدين عبد الرحمن بن أبي بكر، السيوطي، تحقيق: محمد أبو الفضل إبراهيم، مطبعة البابي الحلبي - مصر، الطبعة الرابعة، 1398هـ/1978م. هنا يتمكن الباحث من إدخال المعلومات للبرنامج بالإمكانات التالية: إضافة - تعديل - حذف - تصدير إلى ملف نصي - استيراد من ملف نصي وسيمكنه إضافة بيانات الكتب ضمن مجموعات يقوم بإنشائها؛ مثلاً: المعاجم اللغوية - الفقه الحنفي - التفسير، إلخ. نفس فكرة الإضافة في الاستبدال المتعدد. 2- تبويب إدراج فهرس المصادر والمراجع: يمكنه اختيار مجموعة كتب معينة لتظهر الكتب المرتبطة بها مع معلوماتها كاملة، أو يمكنه اختيار( كل) لتظهر له كل الكتب دون اعتبار مجموعة معينة. قائمة الكتب ستكون قابلة لتحديد كتب معينة من هذه القائمة. بالأسفل خيارات لتحديد طريقة الترتيب في فهرس المراجع؛ مثلاً الترتيب حسب التالي: - اسم الكتاب، اسم المؤلف ولقبه، المحقق، دار النشر، بلد النشر، رقم الطبعة، تاريخ الطبعة. - لقب المؤلف، اسم المؤلف، اسم الكتاب، المحقق، دار النشر، بلد النشر، رقم الطبعة، تاريخ الطبعة. - اسم الؤلف، لقب المؤلف، اسم الكتاب، المحقق، دار النشر، بلد النشر، رقم الطبعة، تاريخ الطبعة. وهكذا... بمجرد نقر زر إدراج، يتم إدراج الكتب المحدد مع بياناتها حسب طريقة الترتيب المختارة. ما رأيك بهذا، وهل لك تعقيبات أو توجيهات أو اقتراحات؟ أرجو الإفادة في هذا الموضوع.

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

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

_البرنامج 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

تفضل با صديقي 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

تفضل تم عمل كل المطلوب بصورة أفضل عند الضغط على New Invoice , سوف يتم الترحيل الى الصفحة الأخرى ثم يكتب رقم الفاتورة التالية لا تقوم بكتابة رقم الفاتورة بنفسك -فالأكسيل سوف يقوم بكتابتها لك كود ترحيل الفاتورة.xlsm