الرائد77

تفضل تم تعديل  الكود ليعمل بشكل أسرع بكثير  من قبل
Financial.xlsb

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

تفضل أخي
الكود يعمل بسرعة جيدة في حالة وجود بيانات أكثر . يعمل جيدا
Private Sub CommandButton3_Click() Application.Calculation = xlCalculationManual Application.ScreenUpdating = False Application.DisplayStatusBar = False Application.EnableEvents = False If MsgBox("سيتم الحذف هل أنت متأكد؟", vbQuestion + vbYesNo) = vbYes Then Sheets("الأصناف").Cells(r, 1).EntireRow.delete MsgBox "تمت عملية الحذف بنجاح" For Y = 1 To 7 Controls("textbox" & Y).Value = "" On Error Resume Next Next Y ListBox1.Clear UserForm_Activate Else Exit Sub End If Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True Application.DisplayStatusBar = True Application.EnableEvents = True End Sub  
 
حذف صنف.xlsm

تفضل
Private Sub UserForm_Initialize() ThisWorkbook.Sheets("sheet1").Visible = True ThisWorkbook.Sheets("sheet1").Select Me.ListBox1.ColumnCount = 5 lrw = Sheets("sheet1").Cells(Rows.Count, 1).End(xlUp).Row For i = 3 To lrw If Cells(i, 1) <> "" Then With ListBox1 .AddItem (Cells(i, 1)) .Column(1, .ListCount - 1) = Cells(i, 2) .Column(2, .ListCount - 1) = Cells(i, 3) .Column(3, .ListCount - 1) = Cells(i, 4) .Column(4, .ListCount - 1) = Cells(i, 5) End With End If Next End Sub المصنف1.xlsm

تفضل
المفروض هذا طلبك
Book1 (2).xlsm

touati.xlsm

غير خصاىص userform  . كما في الصوررة  ShowModal  من القيمة false الى true  لا يمكنك الكتابة . او اتركها 
false  للكتابة على الصفجة و محرر الاكواد شغال.

تفضل . غير الكود الى هدا
Sub Send_Mail(SendTo As String, ToMSg As String, Signature As String) Dim OutlookApp As Object Dim OutlookMail As Object Set OutlookApp = CreateObject("Outlook.Application") Set OutlookMail = OutlookApp.CreateItem(0) Signature = OutlookMail.Body With OutlookMail .To = SendTo .CC = "" .BCC = "" .Subject = Range("n1").Value .Body = ToMSg & vbNewLine & Signature .Send End With Set OutlookMail = Nothing Set OutlookApp = Nothing End Sub اذا لم يعمل معك. فعل signature على الاوتلوك. الكود ييقوم باظهار signature الافتراضي على الاوتلوك
Send Mass Emails Through Outlook Using Excel VBA YasserKhalil Officena.xlsm

تفضل أخي
Set myRange = ws.Range("c2", ws.Range("c2").End(xlDown)) Set myList = New Collection On Error Resume Next Me.ListBox1.Clear For Each myCell In myRange.Cells If myCell = ComboBox1.Value Then myList.Add myCell.Offset(0, -1).Value, CStr(myCell.Offset(0, -1).Value) End If Next myCell On Error GoTo 0 For Each myVal In myList Me.ListBox1.AddItem myVal Next myVal End Sub '----------------------------------------- Private Sub UserForm_Initialize() Dim myList As Collection Dim myRange As Range Dim ws As Worksheet Dim myVal As Variant Set ws = ThisWorkbook.Sheets("stock") Set myRange = ws.Range("c2", ws.Range("c2").End(xlDown)) Set myList = New Collection On Error Resume Next Me.ComboBox1.Clear For Each myCell In myRange.Cells myList.Add myCell.Value, CStr(myCell.Value) Next myCell On Error GoTo 0 For Each myVal In myList Me.ComboBox1.AddItem myVal Next myVal End Sub
المصنف2.xlsm

تفضل تم عمل المطلوب
الدليل بالصورة 


الطلبة.xlsm

ضع هدا الكود و يعمل معك 100//100
TextBox4.Value = Format(Sheets(1).Range("a5").Value, "HH:mm:ss")  
تواتي 34 (1).xlsm

تفضل هدا الماكرو
يعتمد على تسجيل التاريخ اليوم في الخلية A1
ادا وجد تاريخ اليوم هو نفسه تاريخ اليوم . لن يشتغل الماكرو . و ان وجد  تاريخ غير اليوم يشتغل عادي و يسجل تاريخ اليوم في الخلية A1
Book2.xlsm

تفضل جرب هدا
تواتي29).xlsm

تفضل
تواتي 28.xlsm

تفضل.
 
نموذج المطلوب.xlsm

تفضل
اضافة زر لحدف الصورة من الشيت في الملف المرفق
و ادا اردت من زر التصدير الى الشيت أن يحذف الصورة و يرسل الجديدة مكانها بدون زر حذف على الفورم
 
غير كود التصدير الى هذا
Private Sub CommandButton10_Click() Dim Image As Variant Dim L As Single, T As Single, W As Single, H As Single ActiveSheet.Pictures.Delete L = Range("n32:r38").Left T = Range("n32:r38").Top W = Range("n32:r38").Width H = Range("n32:r38").Height Image = TextBox1.Value If Image <> False Then Sheet4.Shapes.AddPicture Image, True, True, L, T, W, H End If End Sub  
تواتي 23.xlsm

تفضل
شهادة.xlsm

انت تستتعمل  windows  xp حاول تثبيت هدا الملف 
https://download.microsoft.com/download/1/f/4/1f477e1b-4534-48ff-b31e-eb6f29b8a85f/VBA64-KB822150-X86-FRA.exe
و جرب الملف المرفق
cheque.xlsm

تم التعديل. استبدل الكود السابق بهذا
Sub pdfcopy2() Application.Calculation = xlCalculationAutomatic Application.DisplayStatusBar = False Application.EnableEvents = False Dim wsA As Worksheet Dim wbA As Workbook Dim strName As String Dim strPath As String Dim strFile As String Dim strPathFile As String Dim myFile As Variant Dim lOver As Long On Error GoTo errHandler Set wbA = ActiveWorkbook Set wsA = ActiveSheet strPath = ThisWorkbook.Path If strPath = "" Then strPath = Application.DefaultFilePath End If strPath = strPath & "\" For i = 2 To 4 If i <> "" Then strName = i & "-" & Sheets(i).Name & "-" & Sheets(i).Range("b3").Value strFile = strName & ".pdf" strPathFile = strPath & strFile If bFileExists(strPathFile) Then lOver = MsgBox("ÇáãáÝ ãæÌæÏ ãÓÈÞÇ.åá ÊÑíÏ ÇÓÊÈÏÇáå¿", _ vbQuestion + vbYesNo, "ãáÝ ãæÌæÏ") If lOver <> vbYes Then myFile = Application.GetSaveAsFilename _ (InitialFileName:=strPathFile, _ FileFilter:="PDF Files (*.pdf), *.pdf", _ Title:="ÅÎÊíÇÑ ãÌáÏ ÇáÍÝÙ") If myFile <> "False" Then strPathFile = myFile Else GoTo exitHandler End If End If End If Sheets(i).ExportAsFixedFormat _ Type:=xlTypePDF, _ Filename:=strPathFile, _ Quality:=xlQualityStandard, _ IncludeDocProperties:=True, _ IgnorePrintAreas:=False, _ OpenAfterPublish:=False End If Next i MsgBox "Êã ÅäÔÇÁ ÇáãáÝ ÈÅÓã ÇáãÚäí: " & vbCrLf & strPathFile errHandler: Resume exitHandler exitHandler: Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True Application.DisplayStatusBar = True Application.EnableEvents = True End Sub  
17 (1).xlsm

تفضل
Private Sub CommandButton2_Click() ActiveSheet.PrintOut From:=Range("B8"), To:=Range("C8"), Copies:=1, Collate:=True End Sub تواتي 12.xlsm

تفضل
تحديد الاسماء الثلاثية المكررة
11.xlsm

=MAX(Sheet1!$D$6:$D$17;Sheet2!$F6:$F17)  
تواتي9 (1).xlsm

تفضل
تواتي9.xlsm

الكود يعمل اوتوماتيكيا حسب عدد الاوراق
احذف الاوراق التي لا تحتاجها . و الكود سيظل يعمل بشكل عادي
تعديل على التسمية . حسب اسم ورقة العمل.
 
الملف المرفق 
17.xlsm

تفضل
تواتي7.xlsm