الـعيدروس

السلام عليكم بارك الله فيك استاذ سليم فكرة جميله عملت عليها بطريقتي امل ان تثري Ali_Hid1.xlsm

السلام عليكم تفضل Option Explicit Sub Ali_Hid() Dim R As Range Dim Rng As Range For Each R In [E1:E500] If R > "" And R.Offset(0, 1) > "" Then If R = "--" And R.Offset(0, 1) = "--" Then If Rng Is Nothing Then Set Rng = R Else Set Rng = Union(Rng, R) End If End If End If Next R If Not Rng Is Nothing Then Rng.EntireRow.Hidden = True Set Rng = Nothing End Sub

السلام عليكم جرب هذا التعديل على الكود Private Sub CommandButton1_Click() Dim origSht As Worksheet Dim destSht As Worksheet Set origSht = Worksheets("sheet 2") sheetsname = InputBox("Enter the sheet name!" & vbNewLine & vbNewLine & "Example:- the sales", "Attention") If sheetsname = "" Then MsgBox "again please", , "Attention" Exit Sub End If If sheetsname = (Sheets(Sheets.Count).Name) Then MsgBox "This Name already Exists", , "Attention" Exit Sub End If Sheets.Add(After:=Sheets(Sheets.Count)).Name = sheetsname Set destSht = ActiveSheet origSht.Cells.Copy Destination:=destSht.Cells Dim cr As ChartObject With destSht For Each cr In destSht.ChartObjects If cr.Index = 1 Then .ChartObjects(cr.Name).Chart.SetSourceData Source:=.Range("C27,O27:P27") If cr.Index = 2 Then .ChartObjects(cr.Name).Chart.SetSourceData Source:=.Range("C28,O28:P28") Next cr End With End Sub

السلام عليكم تفضل بينقصك شي الخلايا التي عليها دمج Ali_1تعديل فورم.xlsm

هذا ملفك ينفذ حذف التكرار مع الكود الموجود سلفا امر تسليم1 CBS.xlsm

السلام عليكم استخدم ازالة التكرارات الخاصة بالاكسل Sub Delt() Dim Lr Lr = Cells(Rows.Count, "A").End(xlUp).Row Range("A8:F" & Lr).RemoveDuplicates Columns:=1, Header:=xlYes End Sub

السلام عليكم بإمكانك إستخدام التالي بدلاً عن الاول بحيث يسهل فهم المعادلات المستخدمة Private Sub TextBox1_Change() Ali_S End Sub Private Sub TextBox2_Change() Ali_S End Sub Private Sub TextBox3_Change() Ali_S End Sub Sub Ali_S() If TextBox1 <> "" And TextBox2 <> "" And TextBox3 <> "" Then If TextBox1 = 3 Then TextBox4 = Se(Range("tabl1"), TextBox2, Range("tabl2"), TextBox3) End If End If End Sub Function Se(Tb1 As Range, V1 As Integer, Tb2 As Range, V2 As Integer) Dim M1, M2 On Error Resume Next With WorksheetFunction ' بحث بالعمود الاول للجدول1 ' لارجاع رقم الصف M1 = .Match(V1, Tb1.Columns(1), 0) ' بحث الجدول2 لارجاع رقم العمود M2 = .Match(V2, Tb2, 0) ' دالة Index ' لارجاع قيمة تقاطع صف مع عمود معين Se = .Index(Tb1, M1, M2) End With On Error GoTo 0 End Function البحث في جدول2.xlsm

السلام عليكم تفضل المرفق البحث في جدول1.xlsm

وعليكم السلام ورحمة الله وبركاتة هذا السطر If i Then CreateObject("WScript.Shell").Popup "الاسماء المكرره هيا " & S_F & vbNewLine & String(42, Srt) & vbNewLine & A_1, 1, "اسماء مكرره" استبدله بالتالي If i Then MsgBox "الاسماء المكرره هيا " & S_F & vbNewLine & String(42, Srt) & vbNewLine & A_1, vbInformation, "اسماء مكرره"

نفس الملف لاول مشاركة اخي ياسر وهذه المرفقات الصورة التي تصدرت معي والملف حفظ صورة ياسم خلية.xlsb

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

تأكد من اعدادات اللغة في لوحة التحكم ايش الويندوز المسطب لديك

ولك مثل دعائك اضعاف مضاعفه اخ ماجد جلال في حفظ الله

اذهب لاعدادات واجهة الاكواد Alt+F11 ثم القائمة Tools ثم Options ثم Editor Format وغير لغة الـ Font الـى Courier New (العربية) امل ان يعمل معك هذا بخصوص الاكسل

اخي الكريم هذا نفس السطر MsgBox Cn المضلل بالاحمر وليس هذا الكود A_Trn

MsgBox Cn احذف هذا السطر ستجدة في الكود A_Trn

اذا كنت تقصد تسجيل الغياب تم التعديل على المشاركة السابقة حمل الملف

اقصد مسمى النك نيم لمنتدى اوفسينا التابع لك eyadm حبذا تغيره وشكرا رفع الغياب مشروط بتاريخ معين وليس عشوائي هذا حسب طلبك سابقاً غياب_A4 مع الغياب بعذر .xlsm

السلام عليكم العفو اخ eyadm ولايهمك اي ملاحظات لاتتردد يفضل تغير المسمى لديك للعربي وشكرا تفضل المرفق غياب_A3 مع الغياب بعذر .xlsm

السلام عليكم جرب المرفق Book1_Ali1.xls

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

جرب اضغط Ctrl+F2 شوف بيتنفذ او لا

تفضل طبع وصولات A2- وصلين.xls

تفضل P = ActiveWorkbook.Path & "\" & Format(Now(), "yyyy-mm-dd") & [G1] & MyCount & ".JPEG"

السلام عليكم عدل هذا السطر P = ActiveWorkbook.Path & "\" & [G1] & MyCount & ".JPEG"