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

وعليكم السلام كان عليك من البداية استخدام خاصيىة البحث في المنتدى فهذا الرابط به ما تريد 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

السلام عليكم ورحمة الله وبركاته اخواني عندي فورم فيه اضافة صورة او ملف PDF خارج اكسس وشغال معي تمام ولكن المشكلة في عرض المرفق حطيت حقل (Image) عند العرض البيانات تظهر الصور اما اذا كان المرفق ملف PDF لايظهر غير وحطيت حقل (WebBrowser) عند عرض البيانات اذا كانت صورة تظهر بشكل كبير كما في الصورة الأولى وانا اريد ان تظهر بحجم صغير ولكن كانت الملف المرفق هو PDF تظهر لي هذه الرسالة كما في الصورة الثانية اريد انا ان يظهر رمز الأيقونة وعند الصغط عليها يفتح

الله يسلم حضرتك استاذى الجليل واخى الحبيب استاذ @محمد صلاح1 جزاكم الله خيرا

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

ملاحظة اخيرة

حقظك الله اخي سليم كل الشكر و التقدير

تم التعديل على الماكرو (فقط للفنادق ) اما الباقي فيما بعد لضيق الوقت 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

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

ادراج وحذف صورة-1.rar اذا تريد تضيف الصورة الى البرنامج يتضخم حجم البرنامج ابقى عالمسار فقط افضل تحياتي

احذف هذا الاسطر من الكود ويكفي ان تضيف زر واحد قبل تنفيذ الماكرو 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

تفضل ..... DoCmd.OpenForm "Main", acNormal, , "[M1] ='" & Me.M1 & "'" & "and [M2]='" & Me.M2 & "'" & "and [M3]='" & Me.M3 & "'" & "and [M4]='" & Me.M4 & "'" & "and [M5]='" & Me.M5 & "'" & "and [M6]='" & Me.M6 & "'"

تفضل هذا التعديل اخي الكريم Ex8-30.rar

استاذنا الفاضل / @qathi الله الله عليك اداة في منتهي الروعة ربنا يبارك لك ويجزاك كل خير ويجعله في ميزان حسناتك كل الاحترام والتقدير لك

أخي @حلبي أنصحك بشدة هذه الاداة فيها كل ماتريد وأكثر .. مرفق الملف شريط طباعة.rar

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

أهلا بك في المنتدى -تفضل الصادر والوارد.xlsx

الاسم : معاذ مروان عبد الغفار شاور السن : 30 عام التعليم : دبلوم محاسبه الحالة الاجتماعية ،، متزوج البلد : فلسطين اعمل في متجر سيارات أقيم في فلسطين - الخليل

Forms![form1]![n1] = Forms![form1]!form2!txtSearch Forms![اسم النموذج الرئيسي]![اسم الحقل في النموذج الرئسي] = Forms![اسم الحقل في النموذج الرئسي]![النموذج الفرعي]![الحقل بالنموذج الفرعي]

جرب هذا الملف Classeur02_salim.xlsx

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

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

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

غير اعدادات العرض كما في الصورة المرفقة

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

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

تفضل انظر الى المعادلة جيدا وحاول تفهمها لأننا قمنا بتثبيت خلية تاريخ اليوم بمعنى كتابة الخلية ثم الضغط على f4 لوضعها بين علامات الدولار كما ترى ححساب.xlsm

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

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

وعليكم السلام كان عليك برفع ملف من الأول ولكن قمت بعمل الملف لك تفضل قيمة الساعات الإضافية.xlsm

تفضل عدد السنوات.xlsm

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

اخى الكريم الملف كله مرفوع هنا على هذا الرابط وهو تمام وبلا مشاكل https://up.top4top.net/downloadf-1129unji31-rar.html

اخى الكريم يمكن تكون المشكلة لديك انت فكما ترى بالصورة هذا من الملف المرسل اليك .

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

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

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

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

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

وعليكم السلام لك ما طلبت Test.xlsm

وعليكم السلام -اخى الكريم كان عليك عمل مثل الكود السابق تماما تفضل ترحيل من صفحة الى عدة صفحات.xlsm

تفضل ويمكنك ايضا الإستعانة بهذا الفيديو لتعلم كيفية عمل الرسم البيانى https://www.youtube.com/watch?v=lNGOfeV6egg https://www.youtube.com/watch?v=_hZffmh3xGU رسم بيانى.xlsx

'================ 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 استدعاء صفحه كامله لصفحه لها نفس رؤوس الاعمده