الـعيدروس

السلام عليكم
اسعد مساك اخي سعد عابد
كيف صحتك ان شاء الله تكون بصحة وسلامه
بالامكان عبر هذه المعادلة المعرفة
Function Ali_Sp(D) Dim A Dim i, x, E A = Sheets("الاسعار").Range("B6:D500").Value For i = LBound(A, 1) To UBound(A, 1) If A(i, 2) = D Then E = A(i, 3) E = Split(A(i, 3), "-") x = UBound(E) Ali_Sp = E(x) Exit For End If Next i End Function او عبر هذا الكود
Sub Ali_S() Dim A Dim x, i, E, R A = Sheets("الاسعار").Range("B6:D500").Value For i = LBound(A, 1) To UBound(A, 1) For R = 5 To Cells(Rows.Count, "B").End(xlUp).Row If A(i, 2) = Cells(R, "B") Then E = A(i, 3): E = Split(A(i, 3), "-") x = UBound(E): Cells(R, "C") = E(x) End If Next R Next i End Sub  
 

اخي ابو عيد سبق وان جربت هذه الطريقة
اولا تفتح الواتس من جوالك وتتركه مفتوح عند البدء بتطبيق الكود
ثانيا تسجيل الدخول على واتس الويب https://web.whatsapp.com/ عبر المتصفح وتقراء الباركود
من جوالك "واتس ويب" لاعتماد دخول الواتس من نفس الجهاز 
وتسجيل الاسماء او الارقام في القائمة اذا سجلت اسماء ضروري تسجل نفس الاسم
المسجل في جوالك
يقوم الكود بفتح رابط الواتس عبر المتصفح والبحث عن الاسم او الرقم ويرجع ينسخ الرسالة 
ويحطها بمربع كتابة الرسائل وينقر ارسال وهكذا يكرر العملية اذا سجلت اكثر من اسم 
 

السلام عليكم
جرب المرفق
 
المكملون مع الدرجة Ali_1.xlsm

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

السلام عليكم
جرب المرفق
 
Ali_2تعديل فورم.xlsm

السلام عليكم
تفضل
فاتورة1.xlsm

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

السلام عليكم
جرب هذا التعديل على الكود
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  

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

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

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

السلام عليكم
بعد اذن اخي احمد يوسف
جرب المرفق
Ot1.xlsm

السلام عليكم
اخ ايهاب ملاحظ انك نسخت اكواد حدث Workbook لماكرو
وهذا غير صحيح تعتبر احداث خاصة لاتعمل الا بواجهة المصنف فقط
او يرمز لها بأكواد مثلا حدث WorkBook Open بـ Auto_Open
Private Sub Workbook_Open() Ref_Sh End Sub اذا اردات استخدامه عبر مودويل كالتالي
Sub Auto_open() Application.Run "Thisworkbook.Ref_Sh" End Sub واليك المرفق وبه طلبك
ehab3.xlsm

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

هذا كود ينفذ اختصار زري Ctrl+F
^ يرمز لزر Ctrl و f حرف 
وهذه اختصارات بالامكان استخدامها عبر Application.SendKeys
+ يرمز لزر ShIFT
% يرمز لزر ALT
وهكذا بتفعيل زري سهم يمين مع زر شفت
SendKeys ("+{RIGHT}")  

السلام عليكم
تفضل
Hepr_Ali2.xlsm

السلام عليكم
ضيف هذا السطر اول كود Private Sub Find_T
On Error Resume Next ليصبح كالتالي
Private Sub Find_T() Dim Ar() Dim cel As Range Dim i As Long Me.CM_ListFind.Clear On Error Resume Next ' <<< i = 1 For Each cel In MRng If InStr(1, cel, CStr(Me.CM_TextFind), vbTextCompare) Then ReDim Preserve Ar(i) Ar(i) = cel.Value i = i + 1 End If Next If i Then Me.CM_ListFind.List = Ar Erase Ar End Sub وهذا هو الملف
 
محرك 3بحث.xlsm

السلام عليكم
بهذا الشكل
Public X Sub Macro2() X = "Release" End Sub  
بالامكان ارجاع قيمة المتغير الى قيمة فارغة عند اغلاق المصنف
وعند النقر على الزر يحط قيمتة Release
 
وهكذا بحدث الصفحة
Private Sub Worksheet_SelectionChange(ByVal Target As Range) If ActiveCell.Column = 4 And ActiveCell.Row > 5 Then If Not X = Empty Then MsgBox "الكود يعمل بطريقة صحيحة" End If End If End Sub  

وعليكم السلام ورحمة الله وبركاته
مرحبا بك اخونا azera 1 بين اخوتك 
ماتصبو اليه ارى تحميل Office 365
والاشتراك فيه بمبلغ زهيد سنوي 400 ريال سعودي
وبالامكان شراء تراخيص عبر مواقع اخرى ارخص
 

array  هذي عبارة عن جدول او جداول
ubound للاشارة عن البعد الاخير سوى لاعمدة  او للصفوف للجداول
مثلا
استخدام Ubound للـ Array
A = Array(1,2,3,4,5) لمعرفة عدد بيانات المتغر A
msgbox Ubound(A) طبيعة الحالة النتيجة 4 لان اي جدول يبداء بصفر وليس بـ 1 الا اذا تم الاشارة في بداية المودويل بالجملة Option Base 1 كالتالي
Option Base 1 Sub Test() Dim A A = Array(1, 2, 3, 4, 5) MsgBox UBound(A) ' 5 End Sub  
او بدون الاشارة كالتالي النتيجة 4
Sub Test() Dim A A = Array(1, 2, 3, 4, 5) MsgBox UBound(A) ' 4 End Sub وبطبيعة الحالة عند استخدام الحلقات التكرارية يستخدم للمصفوفات للاشارة للبداية بكلمة Lbound  بدلاً الخطاء اذا اشرت بـ 0 او 1
وللاشارة بالنهاية بـ Ubound كالمثال التالي
Option Base 1 Sub Test() Dim A A = Array(1, 2, 3, 4, 5) For i = LBound(A) To UBound(A) MsgBox A(i) ' 1,2,3,4,5 Next i End Sub  
 
ولها استخدامات اخرى بإمكانك مراجعة موضوع استاذنا الغالي عبدالله باقشير لشرح المصفوفات

تفضل انقر على الزر تجدة في ورقة تايم شت
المصنف111.xls

السلام عليكم
 
تفضل
بحث3.rar

السلام عليكم
Function Nm_Prgram(Nm_Pth As String) As Boolean Dim In_c As Integer On Error Resume Next In_c = GetAttr(Nm_Pth) Select Case Err.Number Case Is = 0 Nm_Prgram = True Case Else Nm_Prgram = False End Select On Error GoTo 0 End Function Sub Auto_Open() Dim Pth As String '=============================== ' عادة مسار البرامج Pth = "C:\Program Files\skype" If Nm_Prgram(Pth) Then Else MsgBox " برنامج سكاي غير موجود على جهازك": _ ThisWorkbook.Saved = 1: Application.Quit ' امر اغلاق الملف End Sub

السلام عليكم
 
ادخل رقم الوصل في الخلية الصفراء
تفضل المرفق
برنامج 1.rar

السلام عليكم
 
شاهد المرفق
 
Ali_Key.rar