الرائد77

تفضل أخي الكود يعمل بسرعة جيدة في حالة وجود بيانات أكثر . يعمل جيدا 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 للكتابة على الصفجة و محرر الاكواد شغال.

و عليكم السلام أخي. أانت قلت اذا كان "F3="A يعطي قيمة H3. نلاحظ أن f4=a من أين جاءت 3 و الخلية h4=1 وضح أكثر أخي و ان شاء الله سنجد لك الحل

تفضل . غير الكود الى هدا 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

تفضل Book1.xlsm

لم أفهم المطلوب . ضع النتيجة المراد الحصول عليها جرب الملف المرفق.. قد يكوم هذا طلبك Test.xlsx

وماذا ترى أنت في البرنامج؟ الاكواد تقوم بنفس ماتطلب حرفيا

تفضل أخي 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

تفضل أخي listbox unique.xlsm

هده محاولة تفضل فكرة تسجيل القيم في عمود آخر ثم عند اختيار الخلية a1 و عند اعادة الاختيار يظهر مجموع القيم في الخلية a1 يمكنك التطوير كيفما شئت الجمع.xlsm

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

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

شكرا أخي abouelhassan بارك الله فيك

بارك الله فيك حبيبي Ali Mohamed Ali . و جزاك الله خيرا

نظرا لأن برنامج اكسل لا يقدم خيار المعاينة على اليوزرفورم أردت أن أقدم فكرة للزملاء الكرام و أعضاء المنتدى الاعزاء الفكرة تعتمد على أخذ صورة للنطاق المراد طباعته على القرص و اعادة تحميلها على مربع الصورة مهم جدا : انشاء مجلد لحفظ الصورة على c باسم raed ثم شغل الملف المرفق C:\raed يمكنك تغيير القرص و اسم المجلد في الكود كما تشاء ثم غير اسم المحلد حسب الكود Private Sub CommandButton1_Click() Const RaedN As String = "C:\raed\officena.jpg" Dim rng As Range Dim shtTemp As Worksheet Dim chtTemp As Chart Application.ScreenUpdating = False Set rng = Worksheets("Sheet1").Range("b2:h11") Set shtTemp = Worksheets.Add Charts.Add ActiveChart.Location Where:=xlLocationAsObject, Name:=shtTemp.Name Set chtTemp = ActiveChart rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture chtTemp.Paste chtTemp.Export Filename:=RaedN Me.Image1.Picture = LoadPicture(RaedN) Application.DisplayAlerts = False shtTemp.Delete Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub preview on userform.xlsm

نفس ملفك المررفق. ضع الكود في موديل جديد.

Sub Printg() Application.Calculation = xlAutomatic For J = [Y2] To [Y1] If J <= [Y1] Then ActiveSheet.PrintOut Copies:=1, Collate:=True End If Next End Sub بيان ناجح 6.xls

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

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

استعمل اداة تدقيق الاخطاء في القرص الذي عليه الملف . الضعط على الزر الايمن على القرص ثم ادوات ثم التدقيق الان

تسلم حبيبي abouelhassan

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