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

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

كيفية عمل فورم من خلال الفرام وتخطيط جدول وادراج ماديول جذء 2 الفيديو الصور الملف شرح كيفية عمل فورم من خلال الفرام وطريقة عمل جدول الجذء الثانى.rar

كود جديد بقوم بما تريده تم تغيير اسماء الضفحات لسببين 1- لا أطيق العمل بالكود مع اللغة العربية لصعوبة اتجاهات الكتابة (تارة من الشمال اى اليمين وطوراً بالعكس) 2-سهولة نسخ الكود بدون ان تظهر حروف غريبة) Option Explicit Sub Give_data() Dim Dict As New Dictionary Dim Itm#, i%: i = 2 Dim K Dim SA As Worksheet: Set SA = Sheets("Salim") Dim Mab As Worksheet: Set Mab = Sheets("Mabi3at") Dim X#: X = Application.CountA(Mab.Range("b:b")) With SA.Range("A4").Resize(X) .ClearContents .Offset(, 6).ClearContents End With Do Until Mab.Range("b" & i) = vbNullString K = Mab.Range("b" & i): Itm = Mab.Range("d" & i) If Not Dict.Exists(K) Then Dict.Add K, Itm Else Dict(K) = Dict(K) + Itm End If i = i + 1 Loop With SA.Range("a4").Resize(Dict.Count) .Value = Application.Transpose(Dict.Keys) .Offset(, 6).Value = Application.Transpose(Dict.Items) End With Dict.RemoveAll End Sub الملف SUM_WITH DICTIONARY.xlsm

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

السلام عليكم ورحمة الله استخدم الكود التالى لاحظ الكود سيتغرق تنفيذه حوالى 5 ثوانى او اكثر Sub SumIfCod() Dim ws As Worksheet, Sh As Worksheet Dim C As Range, i As Long, x Dim Rng As Range, LR As Long, y As Double Set ws = Sheets("الاصناف") Set Sh = Sheets("المبيعات") LR = Sh.Range("B" & Rows.Count).End(xlUp).Row Application.ScreenUpdating = False T = Timer i = 4 Do While ws.Range("A" & i) <> "" x = ws.Range("A" & i).Value y = WorksheetFunction.SumIf(Sh.Range("B2:B" & LR), x, Sh.Range("D2:D" & LR)) ws.Range("G" & i) = y i = i + 1 Loop MsgBox (Timer - T) Application.ScreenUpdating = True End Sub

استاذ وجيه لك كل الشكر علي كلماتك ومرورك

الاستاذ / أباالحسن السلام عليكم ورحمة الله شكرا علي هذا المحهود الرائع في برنامج مرتبات المعلميين والاداريين ملحوظة صغيره : يرجي مراجعة طريقة حساب ضريبة كسب العمل وكذلك المفردات التي تدخل ضمن حساب الايراد والاعفاءات * فمثلا الاساسي المجرد ( في 1 / 7 / 2018 تم منح العاملين بالدولية علاوه استثنائية (200 او 190 او 180 جنية ) تضاف علي الاساسي في 1 / 7 / 2018 وهي غير معفية من الضرائب * حساب ضريبة الكسب عند تفسيم المرتب الي شرائح فان الاعفاء الممنوح يتم علي اعلي شريحة بالنسبة للموظف الاول ابو الحسن الشريحة الاولي 22000 جنية يستحق عليها ضريبة 10 % = 2200 جنية الشريحة الثانية 1780جنية يستحق عليها ضريبة 15 % = 267جنية اجمالي الضريبة المستحقة 2200+ 267 = 2467 جنية يتم منح هذا الموظف اعفاء بنسبة 45 % من اجمالي الضريبة ويتحمل نسبة 55 % الضريبة المستحقة = 2467 * 0.55 = 1356 جنية تقسم علي 12 شهر = 113 جنية هذا و الله اعلي واعلم ارجو تقبل هذه الملحوظة وتداركها

إضغط هنا >>>----->>يا باغى الخيــر أقبل 6 دقائق تأخذك الى الفردوس الأعلى لا تبخل على نفسك<<-----<<< إضغط هنا

بص المنشور السابق لردك مباشرة قلت لك ايه انا بس كنت منتظر اشوف انت هتحتاج شئ تانى واللا لاء والتجربة عجبتك اصلا واللا هتزعق لى اتفضل طالما راض عن النتيجة دى EngArb (4).accdb

لسه فى شئ تانى بس انا منتظر ردك الاول طبعا بعد التجربة

ومساهمة منى مع اخى الحبيب @kanory لانى كنت عامل قاعدة لكيبورد قبل كدة كان لازم استخدم الأكواد للتحكم فى كل الأحرف والعلامات طبعا انا كاتب اكواد كتير شوية لكن التحكم فى الموديل هنا افضل قليلا تستطيع ان تلغى ما لا تريد او تريده بأضافة العلامة ' فى اول سطر الكود يعنى مثلا انا لاغيت الاقواس عاوز ترجع الاقواس استبدل الكود ده myData = Replace(myData, "(", "") myData = Replace(myData, ")", "") بهذا الكود 'myData = Replace(myData, "(", "") 'myData = Replace(myData, ")", "") مفيش دلع اكتر من كده يا استاذ @saleh204 الاستعلام Query2 هو النهائى طبعا هو مبنى على الاستعلام Query1 تقدر تشوف الفرق بينهم EngArb (3).accdb

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

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

انا قمت بضغطه واعادة رفعة مرة اخرى حتى يستطيع اساتذتنا الكرام متابعة العمل معك برنامج_العقود.zip

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

أي صنف تزيده او تعدل قيمته يظهر في النتيجة طيعاً بعد تنفيذ الكود بالضغط على الزر ملاحظة الكود يتوقف عن العمل عند اي صف فارغ في شيت الاصناف لذلك لا تترك اي فراغ بين البيانات و اذا اردت حذف صنف من الاصناف عليك حذف (الصف او الصفوف) بالكامل لا لزوم لترتيت الاصناف لان الكود لا ينظر الى المكرر مع انه يقوم بجمع القيم للمكررين مثلا يمكن في اخر صف ادراج الصنف1 و بعده صنف 50 ثم صنف 4 الخ....

الله اعلم لن احاول عمل ذلك او تجربته من قبل جرب انت واخبرنا بالنتيجة

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

---------------------- الطامع_فى_الفردوس_الأعلى.zip

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

ماشاء الله عليك يا @ابا جودى ماهذا الابداع ..؟؟ والاحلى الاسم .. سبقتنا به نتمناه كلنا ذلك ..

لا عليك @ابا جودى شفاك الله وعافاك .. طهور أن شاء الله

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

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

طبعا انا مش عارف مصادر بياناتهم ايه انت ادرى برنامج_العقود.accdb RptAll

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

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

ارفق بى وابدا العد بعد العيد ان شاء الله وابشرك ان شاء الله بهدية قيمة بس فعلا بدات فقدان التركيز تماما فلا لن استطيع الان

وانا سوف ادعوا لكم انتم الاتنين ربنا يوفقكم ويتقبل منك صالح الاعمال وكل سنه وانتم طيبين

انظر الى هذا التعديل لعله يفى بالغرض التعديلsumif.xls

اي يعني لما بيكون المجموع صفر يفترض ان يضع صفر على كل حال اذا كنت لا تريد الصفر يمكن التعديل وذلك باضافة شيء بسيط على سطر واحد بالكود ( ما بين اشارات +++++) Option Explicit Sub sum_if_by_code() Application.ScreenUpdating = False If ActiveSheet.Name <> "الاصناف" Then GoTo Exit_Sub Dim SH_Mab As Worksheet: Set SH_Mab = Sheets("المبيعات") Dim SH_Asnaf As Worksheet: Set SH_Asnaf = Sheets("الاصناف") Dim Rg_Mab As Range Dim Rg_Asnaf As Range Dim My_cel_Mab As Range Dim My_cel_Asnaf As Range Dim m%: m = 0 SH_Mab.Select Set Rg_Mab = SH_Mab.Range("b2", Range("b1").End(4)) SH_Asnaf.Select SH_Asnaf.Range("G4", Range("G3").End(4)).ClearContents Set Rg_Asnaf = SH_Asnaf.Range("a4", Range("a3").End(4)) For Each My_cel_Asnaf In Rg_Asnaf For Each My_cel_Mab In Rg_Mab If My_cel_Asnaf = My_cel_Mab And _ IsNumeric(My_cel_Mab.Offset(, 2)) Then _ m = m + My_cel_Mab.Offset(, 2) Next Rem ++++++++++++++++++++++++++++++++++++++++++++++ My_cel_Asnaf.Offset(, 6) = IIf(m = 0, vbNullString, m) Rem++++++++++++++++++++++++++++++++++++++++++++ m = 0 Next Exit_Sub: Application.ScreenUpdating = True End Sub

كيفية عمل فورم من خلال الفرام وطريقة حفظ الملف جذء 1 الفيديو الصور كيفية عمل فورم من خلال الفرام وطريقة حفظ الملف.rar

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

ممكن هذا الكود بدون SumIf Option Explicit Sub sum_if_by_code() Application.ScreenUpdating = False If ActiveSheet.Name <> "الاصناف" Then GoTo Exit_Sub Dim SH_Mab As Worksheet: Set SH_Mab = Sheets("المبيعات") Dim SH_Asnaf As Worksheet: Set SH_Asnaf = Sheets("الاصناف") Dim Rg_Mab As Range Dim Rg_Asnaf As Range Dim My_cel_Mab As Range Dim My_cel_Asnaf As Range Dim m%: m = 0 SH_Mab.Select Set Rg_Mab = SH_Mab.Range("b2", Range("b1").End(4)) SH_Asnaf.Select SH_Asnaf.Range("G4", Range("G3").End(4)).ClearContents Set Rg_Asnaf = SH_Asnaf.Range("a4", Range("a3").End(4)) For Each My_cel_Asnaf In Rg_Asnaf For Each My_cel_Mab In Rg_Mab If My_cel_Asnaf = My_cel_Mab And _ IsNumeric(My_cel_Mab.Offset(, 2)) Then _ m = m + My_cel_Mab.Offset(, 2) Next My_cel_Asnaf.Offset(, 6) = m m = 0 Next Exit_Sub: Application.ScreenUpdating = True End Sub

اين ذهب الماكرو الذي قمت انا بانشائه ===> لا لزوم له تم مسحه هل الماكرو الذي احدثته انت يتولى هذه المهمه اضافة الى مهمة انشاء صفحة جديدة ===> بالطبع هذه مهمته 1- اذا كان عدد الصفوف المملوءة في الشيت الاخير اقل من 11 يتم اضافة ما تريد الى اول صف فارغ في نفس الصفجة حتى يصل عدد الصفوف الى 11 2- و اذا كان عدد الصفوف المملوءة في الشبت الاخير يساوي 11 يتم ادراج شيت جديد الذي يأخد اسم الشيت الذي قبله زائد واحد ويذلك يكون هذا الشيت قد اصبح بدوره اخر شيت و تتم اضافة ما تريد اليه ابتداء من الصف الثاني حتى الرقم 11 ووهكذا دواليك

وذلك بعد استبدال كودك بهذا الكود Option Explicit '//////////////////////////////////////////////////////////////////// 'Password masked inputbox 'Allows you to hide characters entered in a VBA Inputbox. ' 'Code written by Daniel Klann 'March 2003 '//////////////////////////////////////////////////////////////////// 'API functions to be used Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, _ ByVal ncode As Long, ByVal wParam As Long, lParam As Any) As Long Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" _ (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, _ ByVal dwThreadId As Long) As Long Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long Private Declare Function SendDlgItemMessage Lib "user32" Alias "SendDlgItemMessageA" _ (ByVal hDlg As Long, ByVal nIDDlgItem As Long, ByVal wMsg As Long, _ ByVal wParam As Long, ByVal lParam As Long) As Long Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, _ ByVal lpClassName As String, _ ByVal nMaxCount As Long) As Long Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long 'Constants to be used in our API functions Private Const EM_SETPASSWORDCHAR = &HCC Private Const WH_CBT = 5 Private Const HCBT_ACTIVATE = 5 Private Const HC_ACTION = 0 Private hHook As Long Public Function NewProc(ByVal lngCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Dim RetVal Dim strClassName As String, lngBuffer As Long If lngCode < HC_ACTION Then NewProc = CallNextHookEx(hHook, lngCode, wParam, lParam) Exit Function End If strClassName = String$(256, " ") lngBuffer = 255 If lngCode = HCBT_ACTIVATE Then 'A window has been activated RetVal = GetClassName(wParam, strClassName, lngBuffer) If Left$(strClassName, RetVal) = "#32770" Then 'Class name of the Inputbox 'This changes the edit control so that it display the password character *. 'You can change the Asc("*") as you please. SendDlgItemMessage wParam, &H1324, EM_SETPASSWORDCHAR, Asc("*"), &H0 End If End If 'This line will ensure that any other hooks that may be in place are 'called correctly. CallNextHookEx hHook, lngCode, wParam, lParam End Function Public Function InputBoxDK(Prompt, Optional Title, Optional Default, Optional XPos, _ Optional YPos, Optional HelpFile, Optional Context) As String Dim lngModHwnd As Long, lngThreadID As Long lngThreadID = GetCurrentThreadId lngModHwnd = GetModuleHandle(vbNullString) hHook = SetWindowsHookEx(WH_CBT, AddressOf NewProc, lngModHwnd, lngThreadID) InputBoxDK = InputBox(Prompt, Title, Default, XPos, YPos, HelpFile, Context) UnhookWindowsHookEx hHook End Function 'Hope someone can use it! Sub TEST() Dim strAdminPWord As String strAdminPWord = InputBoxDK("Password required to proceed.", "Enter Licence Code") If strAdminPWord = "123" Then MsgBox "cool Password Correct ", vbOKOnly, "success" Else MsgBox ("You entered an invalid password") ' Exit Sub End If End Sub اخفاء باسورد تنفيذ الماكرو.xls

أنا حسب تجربتي لا يستحسن تحويل الخلفية إلى accde لأن قد تكون أكثر عرضة للتلف من accdb بالإضافة إلى أن العميل يستطيع الإطلاع على الجداول و التعديل عليها حتى لو كانت بصيغة accde

تفضل .... Dim dbs As Database, tdf As TableDef Set dbs = CurrentDb For Each tdf In dbs.TableDefs If Left(tdf.Name, 4) <> "msys" _ And tdf.Attributes = 1 Then tdf.Attributes = tdf.Attributes - dbHiddenObject End If If tdf.Attributes = 1073741825 Then tdf.Attributes = 0 Next tdf Set dbs = Nothing Call ViewTablePage

هل جربت هذا الكود .... Private Sub ViewTablePage() DoCmd.SelectObject acTable, , True SendKeys "{F5}" End Sub Private Sub VisibleTable_Click() Dim db As Database Dim tdf As TableDef Set db = CurrentDb For Each tdf In db.TableDefs If Left(tdf.Name, 4) <> "msys" And tdf.Attributes <> 1073741824 Then tdf.Attributes = tdf.Attributes + dbHiddenObject End If If tdf.Attributes = 1073741824 Then tdf.Attributes = 1 Next db.Close Set tdf = Nothing Set db = Nothing Call ViewTablePage End Sub

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

جرب هذا الماكرو (تم تغيير اسماء الصفحات لحسن عمل الكود بالنسبة لنسخه (حتى لا تظهر احرف غريبة) Sub Salim_Macro() Rem Created On 31/5/2019 By Salim Hasbaya Application.ScreenUpdating = False Dim New_ro% Dim t%: t = Sheets(Sheets.Count).Index Dim target_sh As Worksheet Dim M_sh As Worksheet Set M_sh = Sheets("main") Dim last_ro% laste_ro = Sheets(t).Cells(Rows.Count, 1).End(3).Row Select Case laste_ro Case 11 Set target_sh = Sheets.Add(after:=Sheets(t)) ActiveSheet.Name = "MY_sh" & t - 1 M_sh.Range("a1:c1").Copy ActiveSheet.Range("a1") End Select Set target_sh = Sheets(Sheets.Count) New_ro = target_sh.Cells(Rows.Count, 1).End(3).Row + 1 M_sh.Range("a2:c2").Copy _ target_sh.Cells(New_ro, 1) M_sh.Select Application.ScreenUpdating = True End Sub 33_salim.xlsm

وعليكم السلام اخى الكريم فقد تم عرض هذه المشاركة ومناقشتها من قبل على هذا الرابط https://www.officena.net/ib/topic/54296-حساب-مرتب-عنوان-معدل/ حساب الراتب الحالى للموظفين.xlsx

السلام عليكم ارجو تجربة المرفق وقد تم مراعاة معظم المشاكل لكن عليكي بان يكون القسم المدرج تحته البيانات مطابقا للعمل للتوضيح يجب ان يكون العمل مادة القرآن الكريم وليس القران تحت قسم مادة القرآن الكريم وقد تم عمل الملف بطريقة يسهل تعاملك معه بالرغم من انه استغرق 3 ايام لفكرة صغيرة وهي كيفية التعرف علي الاقسام والصف الاخير في كل قسم اخيرا بنفس طريقة عملك لهذا الملف صممي الملف الذي سيتم عليه عملك الفعلي والصقي نسحة فارغة من البيانات وليس من الاقسام في شيت Source فهو الشيت الذي يعتمد عليه لعمل نسخة لكل مدرسة ارجو انني قد فهمت المطلوب ونفذ بالطريقة الصحيحة ولو فيه اي استفسار انا منتظر للرد عليه تحياتي حافظة الدوام أوفيسنا.rar

كل صفحة من اكسل 2010 تحتوي على: 1,048,576 صف (اكثر من مليون صف ) 16,384 عامود (اكثر من 16000 عامود) اي 1048576 × 16384=17,179,869,184 خلية (اكثر من 17 مليار خلية ) اكثر بثلاث مرات عدد سكان الارض هل تستطيع أن تملأها بيانات للتأكيد هذا الماكرو Option Explicit Sub Cells_numbe() Dim x, y, z x = ActiveSheet.Rows.Count y = ActiveSheet.Columns.Count z = x * y Cells(1, 1) = "Rows Count" Cells(1, 2) = "Columns Count" Cells(1, 3) = "Cells Count" Cells(2, 1) = x Cells(2, 2) = y Cells(2, 3) = z End Sub

بارك الله فيك أستاذ سليم كود ممتاز جعله الله في ميزان حسناتك وبعد اذن حضرتك طبعا -ولإثراء الموضوع هذا حل أخر Masry.xlsm

جرب هذا الماكرو Sub FIL_combo() Dim sh As Worksheet Dim obj As Object Set obj = _ CreateObject("System.Collections.Arraylist") For Each sh In Worksheets If sh.Name <> "Main" Then With sh.Range("b2") obj.Add .Value & " " _ & .Offset(, 1).Value End With End If Next Sheets("Main").ComboBox1.List = _ Application.Transpose(obj.toarray) obj.Clear: Set obj = Nothing End Sub Rem===============>> Salim Private Sub ComboBox1_DropButtonClick() FIL_combo End Sub الملف مرفق Masry_SALIM.xlsm

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

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

وعليكم السلام -لابد من رفع ملف العمل حتى تتمكن الأساتذة من المساعدة