ياسر خليل أبو البراء

أخي الحبيب رجب جاويش وأخي الغالي مختار بارك الله فيكما وجزاكما الله خيرأً إليكم هذا الحل إثراءً للموضوع ..الحل معقد بعض الشيء لكنه يلبي الغرض من ناحية إظهار كلمة السر على شكل نجوم أولاً يتم إدراج موديول من النوع Class باسم PwdInputBox ويوضع فيه الكود التالي Function PassInputBox(Prompt As String, Optional PasswordChar As String, Optional Title As String, Optional Default As String, Optional XPos As Long, Optional YPos As Long) Dim UF Dim VUF As Object Dim Lb As Object Dim Tb As Object Dim BOk As Object Dim BCancel As Object Dim VBAVisible As Boolean Dim I As Integer If Len(Title) = 0 Then Title = Application.Name VBAVisible = Application.VBE.MainWindow.Visible Application.VBE.MainWindow.Visible = False Set UF = ThisWorkbook.VBProject.VBComponents.Add(3) Set Tb = UF.Designer.Controls.Add("Forms.Textbox.1", "TextBox1") With Tb .PasswordChar = PasswordChar .Left = 4.5 .Top = 69.75 .Width = 254.25 .Height = 15.75 .Value = Default End With Set Lb = UF.Designer.Controls.Add("Forms.Label.1") With Lb .Caption = Prompt .WordWrap = True .Left = 6.75 .Top = 6.75 .Width = 198 .Height = 54 End With Set BOk = UF.Designer.Controls.Add("Forms.CommandButton.1", "BOk") With BOk .Caption = "OK" .Left = 209.25 .Top = 4.5 .Width = 49.5 .Height = 18 .Default = True End With Set BCancel = UF.Designer.Controls.Add("Forms.CommandButton.1", "BCancel") With BCancel .Caption = "Cancel" .Cancel = True .Left = 209.25 .Top = 27 .Width = 49.5 .Height = 18 End With With UF.CodeModule I = .CountOfLines .InsertLines I + 0, "Public MyText as Variant" .InsertLines I + 1, "Private Sub BCancel_Click()" .InsertLines I + 2, " MyText = False: Me.Hide" .InsertLines I + 3, "End Sub" .InsertLines I + 4, "Private Sub BOk_Click()" .InsertLines I + 5, " MyText = TextBox1.Value: Me.Hide" .InsertLines I + 6, "End Sub" .InsertLines I + 7, "Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)" .InsertLines I + 8, " If CloseMode = 0 Then Cancel = True: MyText = False: Me.Hide" .InsertLines I + 9, "End Sub" End With With UF .Properties("Caption") = Title .Properties("Width") = 273 .Properties("Height") = 108.75 If XPos > 0 Or YPos > 0 Then .Properties("StartUpPosition") = 0 .Properties("Left") = XPos .Properties("Top") = YPos Else .Properties("StartUpPosition") = 1 End If End With Set VUF = VBA.UserForms.Add(UF.Name) VUF.Show PassInputBox = VUF.MyText ThisWorkbook.VBProject.VBComponents.Remove VBComponent:=UF Application.VBE.MainWindow.Visible = VBAVisible End Function ثم يتم إدراج الكود التالي في موديول عادي .. Sub ShowForm() Dim ANS As Variant Dim App As PwdInputBox Set App = New PwdInputBox ANS = App.PassInputBox("Please Enter The Password", "*", "My Application") If ANS = False Or ANS = "" Then Exit Sub Else If ANS = "123" Then UserForm1.Show Else MsgBox "Incorrect Password", vbCritical End If End Sub وإليكم المرفق فيه تطبيق ما سبق تقبلوا تحياتي Show UserForm By Password Mask For InputBox YasserKhalil.rar

جرب المعادلة التالية =IF(B1<>"",B1,IF(A1<>"",A1,"")) يرجى تغيير اسم الظهور للغة العربية تقبل تحياتي

أخي الكريم سعيد جرب الكود التالي Sub TransferMatchingItems() Dim Ws As Worksheet, Sh As Worksheet, Cel As Range, Found Set Ws = Sheet2: Set Sh = Sheet1 Application.ScreenUpdating = False With Sh For Each Cel In .Range("B8:B" & .Cells(Rows.Count, "B").End(xlUp).Row) Set Found = Ws.Range("C:C").Find(What:=Cel.Value, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False) If Not Found Is Nothing And Not IsEmpty(Cel.Value) Then Cel.Offset(, 3).Value = Found.Offset(, 6).Value End If Next Cel End With Application.ScreenUpdating = True End Sub تقبل تحياتي

طيب لو رجعت كتبت في الخلية A1 مرة تانية ايه المفروض يحصل؟

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

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

يمكن وضع مسافة قبل المعادلة أو علامة التنصيص المنفردة ' ..

أخي الكريم نايف جرب الكود التالي عله يفي بالغرض Private Sub ListBox1_Click() TextBox1.Value = ListBox1.Value End Sub Private Sub TextBox1_Change() Dim A, E ListBox1.Clear With Sheets("Names") A = .Range("A2", .Range("A" & Rows.Count).End(xlUp)).Value End With With CreateObject("Scripting.Dictionary") .CompareMode = vbTextCompare For Each E In A If InStr(1, E, TextBox1.Value, 1) > 0 Then .Item(E) = E Next If .Count > 0 Then ListBox1.List = .Keys End With End Sub Private Sub UserForm_Initialize() Dim myList As Collection Dim myCell As Range, myRange As Range Dim WS As Worksheet Dim myVal As Variant Set WS = ThisWorkbook.Sheets("Names") Set myRange = WS.Range("A2", WS.Range("A2").End(xlDown)) Set myList = New Collection With Me.ListBox1 .ColumnCount = 1 .MultiSelect = fmMultiSelectSingle .ColumnWidths = "50" On Error Resume Next For Each myCell In myRange.Cells myList.Add myCell.Value, CStr(myCell.Value) Next myCell On Error GoTo 0 For Each myVal In myList .AddItem myVal Next myVal End With End Sub تقبل تحياتي

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

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

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

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

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

اقتباس بدون رد !!

أخي الكريم أحمد خبرتي ضعيفة في هذا الخصوص نظراً لأنني لم أقم بمشاركة مصنف من قبل .. جرب الكود التالي وهو أحد روائع أخونا الغائب عن العين الحاضر في القلب أبو تراب غفر الله لي وله Sub SharedFile() With ActiveWorkbook Application.DisplayAlerts = False .ExclusiveAccess Application.DisplayAlerts = True ActiveSheet.Unprotect 1 'ضع أكوادك ها هنا ActiveSheet.Protect 1 Application.DisplayAlerts = False .KeepChangeHistory = True .SaveAs Filename:=ActiveWorkbook.FullName, AccessMode:=xlShared Application.DisplayAlerts = True End With End Sub إن شاء الله يحل المشكلة بالنسبة للمصنف المشترك .. تقبل تحياتي

بارك الله فيك وإليك فيديو فيه شرح لكيفية إخفاء محتويات الخلايا أرجو أن ينال إعجاب الجميع تقبلوا تحياتي

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

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

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

أخي الكريم ضع علامة الدولار $ قبل اسم العمود

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

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

هل جربت الحل الثاني الذي استخدمت فيه دالة معرفة؟؟؟ يوجد لديك أكثر من حل مقدم ..

هل تم المطلوب على خير وأدت أي الأكواد الغرض معك أخي الفاضل .. وجزيت خيراً بمثل ما دعوت لنا

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