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

وعليكم السلام كان عليك من البداية استخدام خاصيىة البحث في المنتدى فهذا الرابط به ما تريد https://www.officena.net/ib/topic/92854-تقسيم-الرقم-القومى/?tab=comments#comment-580064 استخراج الأرقام من الرقم الوطني.xlsx

وعليكم السلام يمكن عمل هذا بهذا الكود في حدث الصفحة وبالنسبة عن كيفية تطبيق هذا بملف اخر فيمكنك دراسة الكود جيدا ونقله وتطويعه في عمل اخر Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean) 'Only run the code if the user selected a cell in our defined range: If Not Intersect(Target, Me.Range("Table_Schedule")) Is Nothing Then 'Declare variables Dim rInt As Range Dim rCell As Range Dim rw As Long Dim xLoc As Range Set rInt = Me.Range(Me.Cells(Target.Row, "d"), Me.Cells(Target.Row, "p")) If Not rInt Is Nothing Then 'Look for a response in our answer range Set xLoc = rInt.Find("x ") If Not xLoc Is Nothing Then 'If there was a response and the response was in the same column _ 'we selected, wipe the response and exit the sub. If Target.Column = xLoc.Column Then rInt.Value = vbNullString Exit Sub 'Else, wipe the previous response and add the new response Else rInt.Value = vbNullString Target.Value = "x " End If 'If there were no previous responses... Else: Target.Value = "x " End If End If End If End Sub Weekly chore schedule1.xlsm

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

جرب هذه المعادلة في الخلية B2 واسحب يساراً ثم نزولاً =IF(LEN($A2)-COLUMNS($A$1:A1)<=-1,"",MID($A2,LEN($A2)-COLUMNS($A$1:A1)+1,1)) الملف مرفق national_number.xlsx

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

اهلا بك اخى الكريم في المنتدى تم الحل بهذه المعادلة =IFERROR(VLOOKUP(G2,$A:$B,2,0),"") فالمشكل كان في خطأ كتابة هذه الأسماء في العمود الأول A فربما كان هناك مسافات زائدة في الخلية 1مساعدة.xls

وعليكم السلام-تفضل لك ما طلبت حساب اجماليات السلع.xls

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

واخيرا .. أهلاً بعودتك أخي @ابا جودى كم أسعدت جداً برجوعك لنا .. الحمدلله على سلامتك أخي الغالي

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

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

تفضل لك ما طلبت ربط قائمة منسدلة بأخرى.xlsm

ملاحظة اخيرة

استبدل حرف الـــ E بحرف الـــ L في الماكرو

تم معالجة الامر Classeur02_Mawad_new 9.xlsx

تم التعديل على الماكرو (فقط للفنادق ) اما الباقي فيما بعد لضيق الوقت Option Explicit Sub Give_data1() Rem =====>>> Created By Salim Hasbaya On 1/9/2019 Dim Dict As Object Dim st, ff% Dim Ro%, x%, t%, arr Dim Itm, i%: i = 2 Dim K, Ky, xx% ': xx = 3 Dim SA As Worksheet: Set SA = Sheets("Salim") Dim DA As Worksheet: Set DA = Sheets("data") Dim My_col As New Collection Dim My_col2 As New Collection 'For remove the Contents Of the sheet "Salim" Please remove _ the "'" from the next line 'SA.Range("a3").Resize(10000, 5).ClearContents xx = SA.Cells(Rows.Count, "c").End(3).Row xx = IIf(xx = 2, 3, xx + 2) Set Dict = CreateObject("SCRIPTING.DICTIONARY") Ro = DA.Cells(Rows.Count, "G").End(3).Row For i = 2 To Ro On Error Resume Next My_col.Add CDate(DA.Range("G" & i).Value), CLng(DA.Range("G" & i).Value) & " " Next For i = 1 To My_col.Count For x = 2 To Ro If DA.Cells(x, "G") = My_col(i) Then K = DA.Cells(x, "L") Itm = Application.CountIf(DA.Range("L2:L" & x), DA.Range("L" & x)) If Not Dict.Exists(My_col(i)) And Itm = 1 Then Dict.Add My_col(i), K Else Dict(My_col(i)) = Dict(My_col(i)) & "," & K End If End If Next x SA.Range("A" & xx) = My_col(i) For Each Ky In Dict.keys arr = Split(Dict(Ky), ",") For ff = 0 To UBound(arr) On Error Resume Next My_col2.Add arr(ff), arr(ff) Next ff If My_col2(1) = "" Then My_col2.Remove (1) On Error GoTo 0 Erase arr ReDim arr(1 To My_col2.Count) For ff = 1 To My_col2.Count arr(ff) = My_col2(ff) Next ff t = UBound(arr) If t >= 1 Then SA.Cells(xx, 3).Resize(UBound(arr) - LBound(arr) + 1) = _ Application.Transpose(arr) End If xx = SA.Cells(Rows.Count, "c").End(3).Row + 2 Dict.RemoveAll: Erase arr: Set My_col2 = New Collection Next Ky Next 'For remove the Contents Of the sheet "Data" Please remove _ the "'" from the next line 'kiLL_data Dict.RemoveAll: Erase arr: Set My_col2 = Nothing Set My_col = Nothing: Set SA = Nothing: Set DA = Nothing End Sub '++++++++++++++++++++++++++++++++++++++ Sub kiLL_data() Sheets("Data").Range("a2", Range("L1").End(4)).ClearContents End Sub الملف مرفق Show Sales_salim_ 2019_new.xlsm

حسب مافهمت وما استطعت فعله شوف المرفق Ex8-30.accdb

الاستاذ @ازهر عبد العزيز فقط الكود

احذف هذا الاسطر من الكود ويكفي ان تضيف زر واحد قبل تنفيذ الماكرو ActiveWindow.ScrollColumn = 3 ActiveWindow.ScrollColumn = 2 ActiveWindow.ScrollColumn = 1 ActiveSheet.Buttons.Add(58.5, 86.25, 114.75, 35.25).Select Selection.OnAction = "البحث" Selection.Characters.Text = "البحث"

جرب هذا الكود Option Explicit Sub Give_data() Dim Dict As Object Dim Itm, i%: i = 2 Dim K, Ky, xx%: xx = 3 Dim SA As Worksheet: Set SA = Sheets("Salim") Dim DA As Worksheet: Set DA = Sheets("data") Set Dict = CreateObject("SCRIPTING.DICTIONARY") SA.Range("A2").CurrentRegion.Offset(1).ClearContents Do Until DA.Range("G" & i) = vbNullString K = DA.Range("G" & i): Itm = DA.Range("L" & i) If Not Dict.Exists(K) Then Dict.Add K, Itm Else Dict(K) = Dict(K) & "," & Itm End If i = i + 1 Loop SA.Range("A3").Resize(Dict.Count) = _ Application.Transpose(Dict.keys) For Each Ky In Dict.keys SA.Cells(xx, 3) = Join(Split(Dict(Ky), ","), ",") xx = xx + 1 Next Dict.RemoveAll: i = 2: xx = 3 Do Until DA.Range("G" & i) = vbNullString K = DA.Range("G" & i): Itm = DA.Range("H" & i) If Not Dict.Exists(K) Then Dict.Add K, Itm Else Dict(K) = Dict(K) & "," & Itm End If i = i + 1 Loop For Each Ky In Dict.keys SA.Cells(xx, 4) = Join(Split(Dict(Ky), ","), ",") xx = xx + 1 Next Dict.RemoveAll: Set Dict = Nothing End Sub الملف مرفق Show Sales_salim_ 2019.xlsm

جرب المرفق 31.accdb

طيب انظر التعديل عند اختيار لغة العربية ستكون كل عناصر في مكانهم كما هو اما عند انجلزية تتغير الى اليسار sa.rar

هذه محاولة اتمنى ان تكون المطلوب قاعده ادخال البيانات.xlsm

تفضل هذا مثال مثال لنقل البيانات.mdb

الله يحفظك أستاذ سليم لو امتلكت ان أعطيك جائزة نوبل لمنحتك اياها لكن طلب اخير أن يظهر الانذار الأول بعد اكتمال 5 ايام متصلة و الانذار الثاني بعد اكتمال 7 ايام متقطعة و العكس

استخدم هذا الكود ..... Dim c, i c = DCount("[المعرف]", "daraga") DoCmd.GoToRecord , , acFirst For i = 1 To c If IsNull(Me.Date1) Or IsNull(Me.date2) Then Exit Sub Me.age = CalcAge(Me.Date1, Me.date2) Me.tdate = CalcAged(Me.Date1, Me.date2) Me.tmonth = CalcAgem(Me.Date1, Me.date2) Me.tyear = CalcAgey(Me.Date1, Me.date2) DoCmd.GoToRecord , , acNext Next i MsgBox "تم الحساب", vbInformation + vbMsgBoxRight, "حساب"

مشاركة مع أخي @عبد اللطيف سلوم أنظر ... n15.accdb

اشكرك اخى الكريم على سرعة الرد ولكن ليس هذا ما اريده لانه يتم عرض الاقسام بالترتيب الابجدى سواء تصاعدى او تنازلى اما انا فاريد ترتيب اخر 1- معدات 2- مبانى 3- علاقات 4- تخطيط 5- خدمات

ممكن التعامل مع هذا الملف واختيار 5 ايام متتالية او 7 متفرقة او الكل الاكواد اللازمة Option Explicit Sub test_5Dyas() Rem=====>>> Created By Salim Hasbaya On 30/8/219 Dim str$: str = "غ" Dim cont%, col%, k%: k = 35 Dim i%, x%: i = 3 Dim t%, last_ro% Dim my_text: my_text = "انذار 5 (" Dim X_arr(), m%: m = 1 last_ro = Cells(Rows.Count, 2).End(3).Row Range("Ag5").Resize(last_ro - 4, 7).ClearContents If last_ro < 5 Then Exit Sub For col = 5 To last_ro For x = i To k '========================== If Cells(4, x) = "جمعة" Or Cells(4, x) = "سبت" Then GoTo Next_X End If '========================== If Cells(col, x) = "" Then cont = 0 x = x + 1 End If '========================== cont = cont + IIf(Cells(col, x) <> "", 1, 0) '========================== If cont = 5 Then ReDim Preserve X_arr(1 To m) X_arr(m) = my_text & m & ")" m = m + 1 cont = 0 End If '========================== Next_X: Next x On Error Resume Next t = UBound(X_arr) '========================== If t Then Cells(col, "AG").Resize(1, UBound(X_arr)) = X_arr End If '================================ cont = 0 Erase X_arr: m = 1 Next col End Sub '+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Sub test_7Dyas() Rem=====>>> Created By Salim Hasbaya On 29/8/219 Dim str$: str = "غ" Dim cont%, col%, k%: k = 35 Dim i%, x%: i = 3 Dim t%, last_ro% Dim my_text: my_text = "انذار 7 (" Dim X_arr(), m%: m = 1 last_ro = Cells(Rows.Count, 2).End(3).Row Range("Ag5").Resize(last_ro - 4, 3).ClearContents If last_ro < 5 Then Exit Sub For col = 5 To last_ro For x = i To k '========================== If Cells(4, x) = "جمعة" Or Cells(4, x) = "سبت" Then GoTo Next_X End If '========================== '========================== cont = cont + IIf(Cells(col, x) <> "", 1, 0) '========================== If cont = 7 Then ReDim Preserve X_arr(1 To m) X_arr(m) = my_text & m & ")" m = m + 1 cont = 0 End If '========================== Next_X: Next x On Error Resume Next t = UBound(X_arr) '========================== If t Then Cells(col, "Ak").Resize(1, UBound(X_arr)) = X_arr End If '================================ cont = 0 Erase X_arr: m = 1 Next col End Sub '+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Sub all_days() Dim ro%, Col_Num%: Col_Num = 30 Dim xx%, My_count% ro = Cells(Rows.Count, "b").End(3).Row Dim kk%, Mon_array() Dim st$: st = "انذار7(" If ro < 5 Then Exit Sub test_5Dyas For xx = 5 To ro My_count = Application.CountIf(Cells(xx, 3).Resize(1, Col_Num), "غ") My_count = My_count \ 7 If My_count = 0 Then GoTo Next_XX For kk = 1 To My_count Cells(xx, "ak").Offset(, kk - 1) = st & kk & ")" Next Next_XX: Next End Sub الملف مرفق Inzar ALL Days.xlsm

الاخوة الاعزاء تجدون ادناه فكرة مبدئية لعمل معرض صور من روابط صورة خارجية آمل ان يحوز على رضائكم معرض صور فكرة مبدئية.mdb

بعد اذن استاذ حسين مامون جرب هذا الملف لعله يفى بالغرض قوائم اعلام الطلاب االفصل االثاني 2018-2019 --1.xls

بسم الله الرحمن الرحيم احبابنا في الله ادعو الله ان تكونوا بخير وبعد : هذا ملف به اكواد جمعتها وهذبتها لتكون مرجعا لمن اراد كودا من اكواد الترحيل او الاستدعاءات *** ففيه كود استدعاء بيانات صفحه لصفحه اخرى بشرط والشرط موجود في الخليه C1 في هذه الصفحه === *** وفيه كود استدعاء اعمده معينه بدون شرط ==== وفيه كود استدعاء اعمده معينه بشرط داخل الكود === وفيه كود استدعاء اعمده معينه بشرطين من خارج الكود === وفيه كود استدعاء بيانات اعمده معينه بشرطين موجودين داخل الكود وكل كود في صفحه واسطره مشروحه حتى يسهل فهمها وتطويعها لملفاتكم جزاكم الله خيرا إدعوا لكل من كانت له بصمه في هذا العمل بالخير المرجع في الاستدعاءات والترحيل.rar

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

جزاك الله كل خير والحمد لله الذى بنعمته تتم الصالحات

من فضلك عليك برفع الملف الذى به المشكلة للعمل على حلها ان شاء الله

عشان اليوم 24 ساعة ولكى يكون الناتج كرقم وليس كوقت

هذه دالة معرفة لابد من الضغط على Alt +f11 وفتح مديول جديد ثم وضع هذا الكود فيه Function ContDate(MyDate1 As Date, MyDate2 As Date, YMD As String) D1 = Day(MyDate1): D2 = Day(MyDate2) M1 = Month(MyDate1): M2 = Month(MyDate2) Y1 = Year(MyDate1): Y2 = Year(MyDate2) If D1 > D2 Then Dr = D2 + 30 - D1: M = -1 Else Dr = D2 - D1 If M1 > M2 Then Mr = M2 + M + 12 - M1: Y = -1 Else Mr = M2 - M1 Yr = Y2 - Y1 + Y If YMD = "D" Or YMD = "d" Then ContDate = Dr If YMD = "M" Or YMD = "m" Then ContDate = Mr If YMD = "Y" Or YMD = "y" Then ContDate = Yr End Function

تفضل لك ما طلبت عدد السنوات.xlsm

وعليكم السلام تفضل ولكن عليك بتغيير المسار داخل الكود الى ما تريده Sub openwb() Dim sPath As String, sFile As String Dim wb As Workbook sPath = "D:\sarath\PTMetrics\20131004\D8 L538-L550 16MY\" sFile = sPath & "D8 L538-L550_16MY_Powertrain Metrics_20131002.xlsm" Set wb = Workbooks.Open(sFile) End Sub

والأخر ايضا يعمل تمام هل لاحظت الصور ؟

أخى الكريم لاحظ بالصور لا يوجد مشاكل بالتحميل https://up.top4top.net/downloadf-1129unji31-rar.html وايضا هذا رابط اخر على ميديا فاير http://www.mediafire.com/file/5wkob9d35px26mx/كنترول+شيت+2019-ابتدائى+واعدادى-الأستاذ+عبد+البارى.rar

أخى الكريم تم التعديل لاحظ بنفسك هذا هو الكود الجديد 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(ActiveSheet.Name) VlDate = ws.Range("E2").Value '---------------------------------- LR = ws.Cells(Rows.Count, "C").End(xlUp).Row ws.Range("F10:H" & LR + 1).ClearContents Set Rng = ws.Range("E10:E" & 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

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

وعليكم السلام تفضل If.xlsx

وعليكم السلام اهلا بك اخى الكريم فى المنتدى يمكنك قراءة هذا الكتاب ونظرا لكبر حجمه فتم رفعه على موقع خارجى https://up.top4top.net/downloadf-1127xi8eh1-pdf.html

تفضل اخى الكريم هذا رابط جديد https://up.top4top.net/downloadf-1127tmc1g1-rar.html

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

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

بارك الله فيك ولك بمثل ما دعوت لى وزيادة -فالمعادلة تم ضبطها داخل الملف

'================ Sub Trans_Data() 'الكود خاص بالمحترم زيزو العجوز 'يحفظه الله 'تم هذا الكود في 15/11/2017 'الهدف من الكود هو استدعاء صفحة كامله بشرط '================ Application.ScreenUpdating = False Application.Calculation = xlCalculationManual 'الاعلان عن اسماء الشيتات' Dim Main As Worksheet, sh As Worksheet ' الاعلان عن المصفوفتين Dim Arr As Variant, Temp As Variant '(i,j)الاعلان عن ابعاد المصفوفة الاولى ( p ) وعداد المصفوفة الثانية Dim i As Long, j As Long, p As Long ' الاعلان عن المتغير الذى سوف يتم العمل عليه Dim dep As String Set Main = Sheets("المصدر") Set sh = Sheets("الهدف") '======= ' محو البانات القديمة sh.Range("A7:AC" & Main.Range("B" & Rows.Count).End(xlUp).Row).ClearContents ' معيار الاختيار dep = sh.Range("C1").Value ' المصفوفة المصدر Arr = Main.Range("A7:AC" & Main.Range("B" & Rows.Count).End(xlUp).Row).Value ' ابعاد المصفوفة الهدف ReDim Temp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2)) ' طول المصفوفة المصدر For i = 1 To UBound(Arr, 1) 'رقم عمود الشرط If Arr(i, 23) Like "*" & dep & "*" Then 'If Arr(i, 101) = dep Then ' العداد لتحديد طول المصفوفة الهدف p = p + 1 ' عرض المصفوفة الهدف For j = 1 To UBound(Arr, 2) ' تعبئة المصفوفة الهدف من المصفوفة المصدر حسب الشرط Temp(p, j) = Arr(i, j) Next End If Next ' خليه البدايه لصفحه الهدف 'عرض البيانات المطلوبة If p > 0 Then sh.Range("A7").Resize(p, UBound(Temp, 2)).Value = Temp sh.Range("A7:AC" & Rows.Count).Borders.Value = 0 'سطر لاضافة التسطير sh.Range("A7:AC" & Cells(Rows.Count, 2).End(xlUp).Row).Borders _ .Weight = xlMedium ' .Weight = xlThin ' .Weight = xlMedium ' .Weight = xlThick Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub استدعاء صفحه كامله لصفحه لها نفس رؤوس الاعمده