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

الحل هنا Option Explicit Sub My_Data_Sum() Dim Ws As Worksheet Dim Sheets_Names() Dim Client_Name() Dim m%, x%, n%, Ro%, K% Dim Rg_name As Range tak.Cells(2, 2).Resize(500, 8).ClearContents Ro = tak.Cells(Rows.Count, 1).End(3).Row m = -1 For Each Ws In Sheets If UCase(Ws.Name) Like "SH*" Then m = m + 1 ReDim Preserve Sheets_Names(m): Sheets_Names(m) = Ws.Name End If Next Ws x = -1 For n = 2 To Ro If tak.Cells(n, 1) <> vbNullString Then x = x + 1 ReDim Preserve Client_Name(x) Client_Name(x) = tak.Cells(n, 1) End If Next n K = 2 For x = LBound(Client_Name) To UBound(Client_Name) For m = LBound(Sheets_Names) To UBound(Sheets_Names) Set Ws = Sheets(Sheets_Names(m)) Set Rg_name = Ws.Range("A:A").Find(Client_Name(x), lookat:=1) If Not Rg_name Is Nothing Then tak.Cells(K, 3).Resize(, 6).Value = _ Rg_name.Offset(1, 1).Resize(, 6).Value tak.Cells(K, 2) = Sheets_Names(m) tak.Cells(K, "I") = _ Application.Sum(tak.Cells(K, 3).Resize(, 6)) End If K = K + 1 Next m Next x Erase Sheets_Names: Erase Client_Name: Set Ws = Nothing End Sub Final_repory_yara.xlsm

تمت الاجابة على هذا السؤال في مشاركة سابقة لا حاجة للماكرو يكفي ان تغير قيمة الخلية B1 لتحصل على النتيجة (مع انك ارسلت جدول فراغ و قد قمت بتعبئته ببيانات عشوائية بدل فيها ما تراه متاسباً) Adnan mushtaha.xlsx

اعرف الموضوع من السنة الماضية 😁 هذا الموضوع هو احد نقاط الضعف للأكسس ، وماله علاقة بعدد المستخدمين اللي الوندوز يسمح لهم بمجلد المشاركة !! يعني ، لو وضعنا ملف جداول قاعدة البيانات في مجلد مشاركة على الوندوز سيرفر ويسمح لـ 16777 مستخدم ، فنقطة ضعف الاكسس لاتزال تكون موجودة !! فنقطة ضعف الاكسس هو الجداول ، حيث لا يستطيع استيعاب وخدمة عدد كبير (ومعظم قراءتي تقول انهم بين 15-25 شخصا) في آن واحد اذا كان "المستخدمين المتزامنين" يدخلون بيانات !! ومثالي هنا عن برنامج يستخدمه بين 10-15 مستخد متزامنين ، لإدخال البيانات ، في الجداول ، عمل لي الاكسس جدول بإسم USysApplicationLog ، حيث يكتب فيه الاخطاء التي صادفته ولم يتمكن من التغلب عليها ، ومعظم هذه الاخطاء هي: Could not update; currently locked. تعذر التحديث؛ مؤمن حالياً. تعذرت قراءة السجل؛ لتأمينه حالياً من قبل مستخدم آخر. تعذر التحديث؛ مؤمن حالياً من قبل المستخدم 'Admin' على الجهاز 'PC_1'. حوالي 20 خطأ خلال ساعة ونصف !! فالمفروض ان يكون سؤالي في هذا الاتجاه 🙂 وكانت الجداول على كمبيوتر عادي ، وعلى قرص SSD. جعفر

الرابط بالاسفل يحتوي على نسخة 2016 عربي 32 بت حسب الوصف للملف وحجمة 2.26 جيجا بخصوص التنصيب الصامت فاعتذر منك لكون اغلب نسخ التنصيب الصامت مفعله وهذا مخالف لسياسة الموقع ar_office_professional_plus_2016_x86

هذا الكود للنتسيق العامود B في الصفحة الأولى بجب ان يكون فارغاً كلياُ (تم اخفاءه لعدم الكتابة فيه غن طريق الخطأ) Option Explicit Sub My_Data_Sum() Dim Ws As Worksheet Dim Sheets_Names() Dim Client_Name() Dim m%, x%, n%, Ro%, K% Dim Rg_name As Range Dim First_All As Range, MMax% Set First_All = tak.Range("C1").CurrentRegion MMax = First_All.Rows.Count If MMax > 1 Then First_All.Offset(1).Resize(MMax).Clear End If Ro = tak.Cells(Rows.Count, 1).End(3).Row m = -1 For Each Ws In Sheets If UCase(Ws.Name) Like "SH*" Then m = m + 1 ReDim Preserve Sheets_Names(m): Sheets_Names(m) = Ws.Name End If Next Ws ' x = -1 For n = 2 To Ro If tak.Cells(n, 1) <> vbNullString Then x = x + 1 ReDim Preserve Client_Name(x) Client_Name(x) = tak.Cells(n, 1) End If Next n ' K = 2 For x = LBound(Client_Name) To UBound(Client_Name) For m = LBound(Sheets_Names) To UBound(Sheets_Names) Set Ws = Sheets(Sheets_Names(m)) Set Rg_name = Ws.Range("A:A").Find(Client_Name(x), lookat:=1) If Not Rg_name Is Nothing Then tak.Cells(K, 4).Resize(, 6).Value = _ Rg_name.Offset(1, 1).Resize(, 6).Value tak.Cells(K, 3) = Sheets_Names(m) tak.Cells(K, "J") = _ Application.Sum(tak.Cells(K, 4).Resize(, 6)) End If K = K + 1 Next m Next x If K > 2 Then With tak.Range("C2").Resize(K - 1, 8) .Borders.LineStyle = 1 .HorizontalAlignment = 3 .Font.Bold = True .Font.Size = 14 End With With tak .Cells(K, 3) = "Sum" .Cells(K, 4).Resize(, 7).Formula = _ "=SUM(D2:D" & K - 1 & ")" .Cells(K, 3).Resize(, 7) _ .Interior.ColorIndex = 40 .Cells(K, "J").Interior.ColorIndex = 3 .Cells(K, "J").Font.ColorIndex = 2 With .Range("C1").CurrentRegion .Value = .Value For x = 2 To K If .Cells(x, 1).Offset(, -2) <> "" Then .Cells(x, 1).Resize(, 8).Interior.ColorIndex = 35 End If Next End With End With End If Erase Sheets_Names: Erase Client_Name Set Rg_name = Nothing: Set First_All = Nothing Set Ws = Nothing End Sub Final_report_yara.New.xlsm

هذه المعادلة =SUMPRODUCT((LEFT($B$5:$B$19,LEN(E5))=E5&"")*($C$5:$C$19)) sumifs_1.xlsx

وفقا لمستندات الدعم الفني لقاعد بيانات اكسس الحد الاقصي للمستخدمين المتزامين 255 مستخدم وهذا العدد الكبير لقاعدة مخصصة اساسا للاعمال الصغيرة يمكن الوصول له في ظروف عمل محددة ولكن كما اشار الاستاذ الفاضل @sandanet نجد ان العدد الاقصى للمشاركة المتزامنة 20 مستخدم. ماهو الحل ? استخدام windows server وهو ايضا نظريا يتيح تزامن عدد 16777 مستخدم وايضا هذا العدد الكبير جدا في ظروف عمل معينة ولكن التعامل مع اصدارات ويندوز سيرفر تختلف عن نظام التشغيل العادي ويتطلب دارية ومعرفة كبيرة ومواصفات اكبر وتكلفة مادية ايضا سعر الرخصة يتراوح مابين 501 $ الى 6155 $ حسب نوع الترخيص وعدد المستخدمين

اخي الكريم في الويندوز عند الدخول على خصائص مجلد ما واختيار تبويب "مشاركة" ثم مشاركة متقدمة فانك ستلاحظ ان الويندوز يحدد لك اقصى عدد وهو 20 مستخدماً ولا يمكن الزيادة عليه فمها كان نوع قاعدة البيانات او قابلية تحملها فانك محدد بـ 20 مستخدم فقط .. والله أعلم تحياتي

السلام عليكم تواجه كثيراً من مستخدمي إكسل مشكلة تشفير الكتابة العربية في الملفات وخاصة تلك المصدرة من الأجهزة والبرامج الأخرى كجهاز البصمة أو الملفات المحملة من الإنترنت أقدم لكم هذا الكود الذي كتبته بعد بحث في موضوع اليونيكود خاصة أني سابقاً قد عانيت من المشكلة و الحلول البديلة تسمح بمعرفة المحتوى دون القدرة على تحويل الملف بالكامل. ملاحظة : يفضل نسخ الملف المشفر قبل إجراء التحويل عليه. a Code shows invalid/ decrypted characters in Excel properly والحمد لله الذي بنعمته تتم الصالحات و صلى الله على سيدنا محمد وعلى آله وصحبه أجمعين وسلم تسليماً كثيراً. عند فتح الملف هنا زر بالنقر عليه تفتح نافذة لاختيار الملف المطلوب ثم مربع حوار لكتابة اسم الورقة ثم مربع حوار اختيار المجال المراد تغييره عن طريق التحديد. الفانكشن في البداية يمكن استدعاؤها كدالة من دوال إكسل ضمن ورقة البيانات يكفي لذلك = InStead(YourText or Cell Address) Public Function InStead(T1 As String) ' Created by Khalf Officena Forums 20/02/2020 ' www.officena.net ' Hamdi Edlbi ' This Code for Showing Arabic Characters Properly In Excel Dim w As Integer w = Len(T1) For X = 1 To w T2 = Mid(T1, X, 1) T3 = AscW(T2) T4 = Chr(T3) T5 = T5 & T4 Next X InStead = T5 End Function Sub InSteadAll() ' This Sub For Call the Function In The Current Sheet On Error Resume Next Dim C As Range For Each C In Selection C.Value = InStead(C.Value) Next End Sub Sub ChooseRange() 'Choose the Range Dim rng As Range Set rng = Application.InputBox("Select The Range", "Decryption Characters", , , , , , 8) Application.Goto rng ' Call The Sub InSteadAll Call InSteadAll End Sub Sub OpenWorkbook() 'Apply The Code to Another Workbook On Error Resume Next Dim strFile As String Dim X As String strFile = Application.GetOpenFilename() Workbooks.Open (strFile) ' These Followed Couple of Lines are Optional In Case You Need to Get Specific Sheet X = Application.InputBox("Select The Sheet", "Decryption Characters", , , , , , 2) Sheets(X).Activate Call ChooseRange End Sub Decryption_Invalid_Characters.xls

This Macro Sub HideRows() Dim Ro%, i% With Sheets("Sheet1") .Rows.Hidden = False Ro = .Cells(Rows.Count, "C").End(3).Row For i = 1 To Ro If .Cells(i, 1) = vbNullString And _ Application.Sum(.Cells(i, "d").Resize(, 7)) = 0 Then .Cells(i, 1).EntireRow.Hidden = True End If Next End With End Sub '+++++++++++++++++++++++++++++++++++ Sub show_all() Sheets("sheet1").Rows.Hidden = False End Sub

شكرك اخي سليم حاصبيا على سرعة الإجابه جزاك الله خيرا

أضف الى اليوزر زر واكتب له كود (كما في الصورة) الملف مرفق عندما تريد مسح اي بيانات حدد من الليست بوكس ما تريد حذفه ثم اضغط الزر Delete Fatur.xlsm

كنا نستخدم Samsung SSD 960 EVO 4TB ، والسبب في اختياره هو IOPS له عالي (وهو الحال بوجه عام لأقراص SSD) ، القراءة = 3.2 GB/s ، والكتابة = 1.9 GB/s ، فكنت اعتقد بأن هذا سيشفع في تسريع تسجيل البيانات كونها تأتي بسرعة ويتمكن الجدول من تسجيلها بسرعة ، مما سيجعل الجداول دائما مستعدة لتسجيل البيانات التاليه !! الملخص هنا: كل جزئية في تصميم البرنامج له اهميته ، واهمها فهرست الحقول التي يكون لها معايير في الاستعلام او الكود ، في الاستعلام او الكود ، نستخدم فقط الحقول التي نحتاج اليها ، ولا نستخدم النجمة * لجلب جميع الحقول ، ننادي فقط السجلات التي نريدها ، ولا نناديها من الجدول مباشرة حيث لا نستطيع التحكم في مناداة عدد السجلات ، سرعة الكيبل والراوتر وكارت الشبكة والهارددسك ، كلها يجب ان تكون في قمتها ، وبعد هذ نقول ، يافتاح ياعليم ، يارزاق ياكريم ، عملنا اللي علينا ، والباقي عليك 🙂 اخوي خالد ، شكرا على حُسن توضيحك للمعلومة 🙂 جعفر

السلام عليكم ورحمة الله وبركاته الفيديو المرفق أدناه به طريقة للاختيار من قائمة ، ولكن المشكلة أنه عند تطبيقه يعطي النتائج التي تبدأ بالحروف المختارة فقط أود المساعدة في إيجاد طريقة ، بحيث إذا كتبت kis تظهر لي نتيجة Pakistan من ضمن النتائج وشكرا لمساعدتكم

نعم اتفق معك ان قاعدة بيانات اكسس للاعمال الصغيرة لذا يطلق عليها قاعدة بيانات سطح المكتب لذا هنا كان ردي ان مستندات اكسس تشير الى هذا العدد ثم استدركت وهذه الاضافة مني "يمكن الوصول له في ظروف عمل محددة" وكل ما كان البرنامج اكبر ويحتوى على استعلامات معقدة كلما زادت الصعوبة في التزامن لذا نجد دائما ان العديد من الشركات تضع ارقام لا يستطيع المستخدم الوصول لها مثال بعض السيارات الرياضية تجد ان الشركة تذكر ان السيارة تستطيع الوصول الى سرعة 100 كم خلال 3 ثواني بينما عند التجربة نجد انها تستطيع الوصول خلال 4 ثواني او اكثر والسبب ان الوصول لارقام الشركة لابد من حساب كمية الوقود في خزان السيارة وسرعة الريح واتجاهها ونوع الازفلت الخ ايضا حتى مجلد مشاركة ويندوز سيرفر للوصول الى عدد 16777 يتطلب شبكة وسيرفر ذو مواصفات خاصة للسيرفرات خيار ssd غير عملي وانما اقراص hd تدعم الفصل والتركيب دون الحاجة الى اغلاق الجهاز

جارى متابعة المرفقات وشكرا على الرد

تفضل .... Month now sum.accdb

اخي العزيز الكود ليس له علاقة بالفورم ولا الملف انت تحتاج الي كود من الصفر علي ما اعتقد

السلام عليكم ورحمة الله وبركاته ابحث بأي شي تبغيه .. في الخلية C2 .. اكتب .. الاسم .. رقم الطالب الصف المادة العنوان .. saffar1.xlsm

جزا الله خيرا من علمونا الأدب والتواضع في النقاش قبل العلم طبعا هذا الكلام لست أنا المقصود به ولا شك (جزاكم الله عنا خيرا كما تظنون بنا خيرا) تمت الفائدة من الموضوع والحمد لله والشكر موصول لاساتذتي و أصحاب الفضل علينا بعد الله وسأكتفي بذكر هذا فأنا استحي أن أضع أفضل اجابة علي أحد الأجوبة دون الآخر فأنا أريد أن أضع علي كل مشاركة من مشاركات أساتذتي أنها أفضل اجابة ولا شك. ورجاء مشاركة أساتذتي الأجر فهذا المرفق بعد التعديل عليه بما يناسبني قمت بدمج كود الاستاذ جعفر مع فكرة الاستاذ أبو جودي (في استخدام الجدول للاجزاء الخاصة بالاسم) مع الابقاء علي فكرة أستاذنا أبو خليل أنها الاسهل في الاستخدام وتخفيف العبأ في كتابة الاكود. جمعتها لمن مر من هنا واحتاج لها بعدي. ملاحظة: لم ارد خدش كود الاستاذ جعفر لذا وضعت موديل آخر لتنفيذ الفكرة (المقتبسة منه 😀). Test Four Name.rar

Sub Test() Dim a As Variant Dim ar As Range Dim i As Long Dim t For Each ar In Columns(1).SpecialCells(2, 23).Areas Set ar = ar.Offset(1).Resize(ar.Count - 1) For i = 1 To ar.Count ar(i).Offset(, 3) = Format(ar(i).Offset(, 2) / ar.Offset(, 1).Resize(1), "00%") Next ar.Resize(1).Offset(ar.Count + 2, 3) = Format(WorksheetFunction.Sum(ar.Offset(, 3)), "00%") ar.Resize(1).Offset(ar.Count + 4, 3) = Format(ar.Resize(1).Offset(ar.Count + 2, 2) / ar.Resize(1).Offset(ar.Count + 2, 1), "00%") t = t + ar.Resize(1).Offset(ar.Count + 4, 3) Next Cells(Cells(Rows.Count, 2).End(xlUp).Row, 4) = Format(t, "00%") End Sub جرب هذا الكود حسب المعطيات الموجودة في ملفك وإلا يرجى الإيضاح أكثر شكراً

جرب هذا الماكرو Option Explicit Sub test() Dim ro1%, Ro2%, x%, y%, i% Dim t# Dim f_rg As Range Set f_rg = Range("B2:b500"). _ Find("*", LookIn:=xlValues, lookat:=1) x = 4: y = 12 If Not f_rg Is Nothing Then ro1 = f_rg.Row: Ro2 = ro1 Do For i = x To y If Ro2 = 2 Then GoTo Again t = Val(Cells(Ro2, i)) Cells(Ro2, i) = _ IIf(t > 0, -t, Cells(Ro2, i)) Next i Again: Set f_rg = Range("B2:b500").FindNext(f_rg) Ro2 = f_rg.Row If ro1 = Ro2 Then Exit Do Loop End If End Sub الملف مرفق FoMaNsHeE.xlsm

استبدل الرقم 19 بأي رقم تريده (حتى ولو كان 10000) لانه لا حاجة الى العامود بالكامل أكثر من مليون خلية مما يثقل البرنامج

الاستاذ حسين مامون كل الشكر والتقدير لحضرتك امنياتى لحضرتك بالتوفيق والنجاح

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

وعليكم السلام 🙂 هناك الكثير من المواضيع المرتبطة بطلبك : https://www.officena.net/ib/topic/43119-ادارة-المقرات-والمراكز-الامتحانية/ https://www.officena.net/ib/topic/84391-التوزيع-الآلى-للجدول-المدرسى/ https://www.officena.net/ib/topic/12488-طلب-مساعدة-في-عملية-توزيع-معقدة-نوعاً-ما/ https://www.officena.net/ib/topic/77918-مكتبة-الموقع-كود-توزيع-الفصول-أوتوماتيكيا/ https://www.officena.net/ib/topic/70736-التوزيع-الألي-لا-يعمل-كما-يجب/ https://www.officena.net/ib/topic/88422-توزيع-الملاحظين/ https://www.officena.net/ib/topic/99299-مطلوب-توزيع-ركاب-على-الحافلات https://www.officena.net/ib/topic/87955-توزيع-عشوائي-_-توزيع-المدرسين-في-قاعات-الامتحان/ https://www.officena.net/ib/topic/103059-توزيع-طلاب/ ومن هنا ، سترى جميع المواضيع التي تبدأ بكلمة توزيع ، من صفحة 474 الى صفحة 486 قسم الأكسيس Access - صفحه 474 - أوفيسنا (officena.net) ورجاء لا تقول ماحصلت اللي اريده ، وانما حاول وسنساعدك ان شاء الله 🙂 جعفر

مشاركه مع اخى واستاذى العزيز @kanory جزاه الله خيرا الافضل طالما هناك استعلام تجميعى ان تبنى النموذج عليه والخطأ لديك كان فى كتابه الداله فى الحقل وتصحيحه =DLookUp("Debit2";"[Sum_Sales_without_cash_Query]";"[date_of]='" & Format([date_of];"mm/yyyy") & "'") انظر للنموذج Sum_Sales_without_cash_Query المبنى على الاستعلام وللنموذج Table1 بالتوفيق New Microsoft Access Database.rar

بعد ادن استاد سليم ربما يفيدك هذا الشيء حساب تاريخ نهاية الاجازة.xlsm

شكرا استاذ سليم ارفقت الملف فيه مثال هل بالامكان البحث بكثر من معيار الشيت الثاني موضح في المثال الرفق saffar.xlsm

لا أعلم اذا كان هذا المطلوب (لرؤية كافة الصفوف امسح الخلية D2 ) Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Target.Address(0, 0) = "D2" Then using_adV_filter End If Application.EnableEvents = True End Sub '++++++++++++++++++++++++++++++++ Sub using_adV_filter() Dim D As Worksheet Dim S As Worksheet Dim adv_rg As Range Dim Cret As Range Set D = Sheets("Data") Set S = Sheets("Search class") S.Range("A6").CurrentRegion.Clear Set adv_rg = D.Range("A5").CurrentRegion Set Cret = S.Range("D1:D2") adv_rg.AdvancedFilter 2, Cret, S.Range("A6") End Sub saffar.xlsm

تعديل بسيط على الكود مع وضع معادلة مناسبة في العامود Z (يمكن اخفاءه) Private Sub CommandButton2_Click() Dim ws As Worksheet: Set ws = Sheets("inpout1") Dim lr As Integer Dim R, Ahe3b$, Hather$ Ahe3b = "غائب": Hather = "حاضر" ws.Range("w5:w500").ClearContents lr = ws.Range("b" & Rows.Count).End(xlUp).Row For R = 5 To lr ws.Cells(R, "W") = _ Choose(ws.Cells(R, "Z") + 1, Hather, Ahe3b) Next End Sub Khiri.xlsm

هذا الماكرو Private Sub CommandButton2_Click() Dim ws As Worksheet: Set ws = Sheets("inpout1") Dim lr As Integer Dim R, Ahe3b$, Hather$ Ahe3b = "غ": Hather = "حاضر" ws.Range("ai5:ai500").ClearContents lr = ws.Range("b" & Rows.Count).End(xlUp).Row For R = 5 To lr If ws.Cells(R, "B") <> vbNullString Then If Application.CountIf(ws.Cells(R, "H").Resize(, 15), Ahe3b) >= 6 Then ws.Cells(R, "AI") = "غائب" Else ws.Cells(R, "AI") = Hather End If End If Next R End Sub

حلول رائعة ونقاش مثمر.. زادكم الله من علمه استشرت الموقع سابقاً بخصوص إجبار المستخدم على ادخال الأسم كامل وقد أشار عليه بعض الخبراء بالموقع لاني احب التعليم ولكني ضعيف الإمكانيات بالتالي بالجدول الموجود به الأسم .. اذهب الى الخصائص بالأسفل وفى خانة VALIDATION RULE أكتب معادلة لعدد الحروف المطلوبة كتابتها فما أكثر وعلى سبيل المثال أريد عدد الحروف المطلوبة 12 حرف فما أكثر فكانت المعادلة LEN([NAME])>11 وفى خانة التحقق من الصحة أكتب للمستخدم.. "فضلاً أدخل الأسم رباعي" بالنسبة لتكرار البيانات فقد أفاد عليه خبراء الموقع بكتابة الكود التالي لعدم تكرار البيانات وهو به بيانات الحقول الخاص بقاعدة البيانات الخاصة بي ولكن للعلم بالشئ Private Sub VisitDate_AfterUpdate() Dim rst As Recordset Set rst = Me.RecordsetClone rst.MoveFirst Do Until rst.EOF If rst!StartPeriod = Me!StartPeriod And rst!ClinicName = Me!ClinicName And rst!InvoiceNumber = Me!InvoiceNumber And rst!VisitDate = Me!VisitDate Then MsgBox "الروشتة تم إدخالها سابقاً.. برجاء مراجعة الإدخال ", vbMsgBoxRtlReading, "الروشتة مكررة" DoCmd.GoToControl "StartPeriod" Me.InvoiceNumber = "" Me.VisitDate = "" '''Me.Undo '''DoCmd.CancelEvent Exit Do End If rst.MoveNext Loop rst.Close End Sub شكراً لطيب سعة صدركم

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

نعم 🙂 بدل عمل وحدة نمطية جديدة لكل جزء 🙂 جعفر

بعد اذن الاخ حسين لا حاجة للحلقات التكرارية التي ترهق البرنامج (في حال البيانات الكثيرة أكثر من 500 صف) في حين يمكن وضع اليد مباشرة على الخلية المطلوبة بواسطة الدالّة Find Option Explicit Sub find_me() Dim ws1 As Worksheet Dim ws2 As Worksheet Dim RG1 As Range Set ws1 = Sheets("ورقة1") Set ws2 = Sheets("ورقة2") ws2.Cells(7, 2).Resize(4).ClearContents Set RG1 = ws1.Range("A1").CurrentRegion.Columns(2). _ Find(ws2.Range("C3"), Lookat:=1) If Not RG1 Is Nothing Then ws1.Cells(RG1.Row, 1).Resize(, 4).Copy ws2.Cells(7, 2).PasteSpecial (12), Transpose:=True End If Application.CutCopyMode = False ws2.Cells(3, 3).Select End Sub كما يمكن عمل ذلك بمعادلة بسيطة =OFFSET(INDEX(ورقة1!$B$2:$B$9,MATCH($C$3,ورقة1!$B$2:$B$9,0)),,ROWS($A$1:A1)-2) الملف مرفق Adnan.xlsm

اتمنى ذلك وانا بانتظار ذلك المثال الجامع بفارغ الصبر

انتم الخير والبركة استاذي العزيز اي والله على الراس وبالعين

فيك الخير والبركة سيدنا الفاضل 🙂 واخواننا الصعايده على راسنا 🙂 جعفر

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

مشاركة مع اساتذتي الاجلاء

السلام عليكم ورحمة الله تعالى وبركاته استاذى الجليل ومعلمى القدير و والدى الحبيب الاستاذ @jjafferr للعلم منذ فترة تعرضت فى احد الامثلة لــ موضوع parent وأعتقد كان مثال للاستاذة الفاضلة زهرة ولا اخفيكم سرا لم افهم شئ وهممت بالبحث على الانترنت وتوصلت للموقع ذلك الذى اشرتم اليه ولم افهم شئ كذلك الى الان هههههه ..... معلش صعيدي وافهم بصعوبة بالغة

حيث أن البيانات كبيرة بعض الشيء تم تعديل الماكرو ليكون اسرع قليلاُ (بضعة ثواني) Option Explicit Sub Destibute_Data_by_find() If ActiveSheet.Name <> "Sheet1" Then GoTo Leave_Me_Out Dim list As Object Dim Rng As Range, rcell As Range Dim y, x%, m%: m = 2 Dim my_rg As Range Dim Rg As Range Dim f_addres$ Application.ScreenUpdating = False Set list = CreateObject("System.Collections.ArrayList") Set Rng = Sheet1.Range("A1", Sheet1.Cells(Rows.Count, 1).End(xlUp)) '===================== For Each rcell In Rng.Cells If Not list.Contains(rcell.Value) _ And rcell.Value <> "" Then list.Add (rcell.Value) Next rcell '=============================== For x = 0 To list.Count - 1 With Sheets("Sheet" & list.Item(x)) .Cells.ClearContents .Range("c:c").NumberFormat = ("dd-mm-yyyy") Set Rg = Rng.Find(list.Item(x), _ after:=Rng.Cells(Rng.Rows.Count), _ LookIn:=xlValues, lookat:=xlWhole) If Not Rg Is Nothing Then f_addres = Rg.Address Do .Range("a" & m).Resize(, 5).Value = _ Range(Rg.Address).Resize(, 5).Value .Columns("C").AutoFit m = m + 1 Set Rg = Rng.FindNext(Rg) Loop While Not Rg Is Nothing And Rg.Address <> f_addres Else MsgBox "Non items" End If m = 4 End With Next Leave_Me_Out: Application.ScreenUpdating = True End Sub الملف مرفق _Salim ادارات.xlsm

عد الفواتير.zip

إن كان ما تطلبه بالسهولة التي فهمتها . . . مرفق ملف يوضح الطريقة و تحت أمرك في المساعده

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

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

السلام عليكم ورحمة الله هذا حل آخر بالمعادلات لعل فيه ما تريد... بن علية حاجي محضر تصحيح.xls

أخى الفاضل / عمل بسيط .. توزيع الطلاب على كشوف المناداة وأرقام الجلوس تصفح وشاهد .. قم بكتابة البيانات فى الخلايا الغير الملونة فى صفحات " بيانات أساسية / الطلبة / اللجنة " 1 - كشوف منادة تبعا للجان المحددة بالعددالمحدد. 2 - بطاقة لكل طالب كاملة بها كل بياناته . 3 - زر طباعة لكشوف المناداة وملصقات أرقام الجلوس . 2011 أرقام الجلوس والمناداة.rar