علي الشيخ

السلام عليكم.
جرب الكود كالتالي
 
Sub Export_PDF_in_most() Application.ScreenUpdating = False Sheet5.Select ActiveSheet.ExportAsFixedFormat xlTypePDF, "C:\Users\DESKTOP\Dropbox" _ & "\ Escorts Date " & N & UserForm1.TextDate1 & ".PDF", OpenAfterPublish:=True Application.ScreenUpdating = True End Sub  

السلام عليكم
إلحاقا لرد الأستاذ محمود
إنت حدد العمودين من فوق ( يعني أقف على اسم العمود نفسه A مثلا أو B بحيث يتم تظليل العمود بالكامل ) ومن قائمة Date
Filter
Auto Filter
وهيمشي الحال ان شاء الله..
 
---
لو رامات الجهاز بتاعك على الأقل 512 تقدر تنزل أوفيس 2007 والنسخ متوفرة وهتساعدك أكتر سواء تطبيق الشروحات أو ايجاد مساعدة من الأعضاء
تحب نوفرلك لينك وتجرب تنزله وتثبته؟

السلام عليكم أخي الكريم
اتفضل شوف المرفق ان شاء الله يكون الملطوب
في الورق1
الخلايا باللون الأزرق لا تقم بالتعديل عليها
الخلايا التي ستقوم بالتعديل عليها هي
 
تاريخ بداية العمل
تاريخ نهاية العمل
الراتب الأساسي " الخلية باللون الأحمر فقط  اللي هي E25" والباقي يتغير تلقائيا
 
أيضا تم إلغاء أو عدم حساب ما هو فوق السنة الصحيحة بمعنى تم التقريب لأقرب رقم صحيح للأصغر بمعنى مثلا الموظف
اشتغل 10 سنوات ونص السنة سيتم فقط محاسبته على 10 سنوات
حتى لو عمل مثلا 15 سنة و11 شهر سيتم احتساب 15 سنة فقط بدون النظر إلى الشهور
مباشرة الاموال بالكامل.rar

السلام عليكم
أتفضل أخي شوف الملف المرفق وبالنسبة للأكواد في الملف
 
الكود التالي في ThisworkBook
 
الكود التالي يعمل على إضافة القائمة لكليك يمين في ملف الإكسل المحدد
ولكي يتم الإضافة لكل ملفات الإكسل شوف الكود اللي في نهاية الرد
Private Sub Workbook_Activate() Call AddToCellMenu End Sub Private Sub Workbook_Deactivate() Call DeleteFromCellMenu End Sub ثم قم بإدارج موديول عادي وانسخ فيه الكود التالي
الكود يحتوي على 3 ماكرو كل واحد يعمل على تغيير حالة الحروف في باللغة الإنجليزية من حروف كبيرة إلى صغيرة إلى حسب الجملة A - a - Ali
Sub AddToCellMenu() Dim ContextMenu As CommandBar Dim MySubMenu As CommandBarControl 'Delete the controls first to avoid duplicates Call DeleteFromCellMenu 'Set ContextMenu to the Cell menu Set ContextMenu = Application.CommandBars("Cell") 'Add one built-in button(Save = 3)to the cell menu ContextMenu.Controls.Add Type:=msoControlButton, ID:=3, before:=1 'Add one custom button to the Cell menu With ContextMenu.Controls.Add(Type:=msoControlButton, before:=2) .OnAction = "'" & ThisWorkbook.Name & "'!" & "ToggleCaseMacro" .FaceId = 59 .Caption = "Toggle Case Upper/Lower/Proper" .Tag = "My_Cell_Control_Tag" End With 'Add custom menu with three buttons Set MySubMenu = ContextMenu.Controls.Add(Type:=msoControlPopup, before:=3) With MySubMenu .Caption = "Case Menu" .Tag = "My_Cell_Control_Tag" With .Controls.Add(Type:=msoControlButton) .OnAction = "'" & ThisWorkbook.Name & "'!" & "UpperMacro" .FaceId = 100 .Caption = "Upper Case" End With With .Controls.Add(Type:=msoControlButton) .OnAction = "'" & ThisWorkbook.Name & "'!" & "LowerMacro" .FaceId = 91 .Caption = "Lower Case" End With With .Controls.Add(Type:=msoControlButton) .OnAction = "'" & ThisWorkbook.Name & "'!" & "ProperMacro" .FaceId = 95 .Caption = "Proper Case" End With End With 'Add seperator to the Cell menu ContextMenu.Controls(4).BeginGroup = True End Sub Sub DeleteFromCellMenu() Dim ContextMenu As CommandBar Dim ctrl As CommandBarControl 'Set ContextMenu to the Cell menu Set ContextMenu = Application.CommandBars("Cell") 'Delete custom controls with the Tag : My_Cell_Control_Tag For Each ctrl In ContextMenu.Controls If ctrl.Tag = "My_Cell_Control_Tag" Then ctrl.Delete End If Next ctrl 'Delete built-in Save button On Error Resume Next ContextMenu.FindControl(ID:=3).Delete On Error GoTo 0 End Sub Sub ToggleCaseMacro() Dim CaseRange As Range Dim CalcMode As Long Dim cell As Range On Error Resume Next Set CaseRange = Intersect(Selection, _ Selection.Cells.SpecialCells(xlCellTypeConstants, xlTextValues)) On Error GoTo 0 If CaseRange Is Nothing Then Exit Sub With Application CalcMode = .Calculation .Calculation = xlCalculationManual .ScreenUpdating = False .EnableEvents = False End With For Each cell In CaseRange.Cells Select Case cell.Value Case UCase(cell.Value): cell.Value = LCase(cell.Value) Case LCase(cell.Value): cell.Value = StrConv(cell.Value, vbProperCase) Case Else: cell.Value = UCase(cell.Value) End Select Next cell With Application .ScreenUpdating = True .EnableEvents = True .Calculation = CalcMode End With End Sub Sub UpperMacro() Dim CaseRange As Range Dim CalcMode As Long Dim cell As Range On Error Resume Next Set CaseRange = Intersect(Selection, _ Selection.Cells.SpecialCells(xlCellTypeConstants, xlTextValues)) On Error GoTo 0 If CaseRange Is Nothing Then Exit Sub With Application CalcMode = .Calculation .Calculation = xlCalculationManual .ScreenUpdating = False .EnableEvents = False End With For Each cell In CaseRange.Cells cell.Value = UCase(cell.Value) Next cell With Application .ScreenUpdating = True .EnableEvents = True .Calculation = CalcMode End With End Sub Sub LowerMacro() Dim CaseRange As Range Dim CalcMode As Long Dim cell As Range On Error Resume Next Set CaseRange = Intersect(Selection, _ Selection.Cells.SpecialCells(xlCellTypeConstants, xlTextValues)) On Error GoTo 0 If CaseRange Is Nothing Then Exit Sub With Application CalcMode = .Calculation .Calculation = xlCalculationManual .ScreenUpdating = False .EnableEvents = False End With For Each cell In CaseRange.Cells cell.Value = LCase(cell.Value) Next cell With Application .ScreenUpdating = True .EnableEvents = True .Calculation = CalcMode End With End Sub Sub ProperMacro() Dim CaseRange As Range Dim CalcMode As Long Dim cell As Range On Error Resume Next Set CaseRange = Intersect(Selection, _ Selection.Cells.SpecialCells(xlCellTypeConstants, xlTextValues)) On Error GoTo 0 If CaseRange Is Nothing Then Exit Sub With Application CalcMode = .Calculation .Calculation = xlCalculationManual .ScreenUpdating = False .EnableEvents = False End With For Each cell In CaseRange.Cells cell.Value = StrConv(cell.Value, vbProperCase) Next cell With Application .ScreenUpdating = True .EnableEvents = True .Calculation = CalcMode End With End Sub اذا اردت ظهور القائمة في كل ملفات الإكسل يمكنك حذف السطرين التاليين من الكود الأول
Private Sub Workbook_Deactivate() Call DeleteFromCellMenu Book123.rar

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

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

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

السلام عليكم
مرحبا أخي
انا جربت اكثر من شئ صراحة ما اشتغل على Activx Control الموجود " Spinner "
ما ظبطت 
 
ولكن جربت كحل بديل اني عملت 2 ماكرو واحد لزيادة الرقم الذي يتم تغيير والأخر لنقص الرقم 
 
بأكواد بسيطة 
Range("I2").Value = [I2] + 1 Range("I2").Value = [I2] - 1 وتم حماية الصفحة كاملة واستخدام الكود التالي في حدث Thisworkbook  > Workbook_Open
 
حتى يتم حل مشكلة الباسورد
Private Sub Workbook_Open() Dim wSheet As Worksheet     For Each wSheet In Worksheets       wSheet.Protect Password:="", _         UserInterFaceOnly:=True Next wSheet End Sub الباسورد طبعا انا حطيته فارغ ""
وإنما لو في باسورد أخر هيكون مكانه كالتالي
wSheet.Protect Password:="كلمة السر تكتب هنا ", _ المنادة 2.rar

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

اتفضل اخي شوف المرفق ان شاء الله يكون هو المطلوب
مثال.rar

شوف كده أخي الكريم ان شاء الله يكون ضبط
BOOK.rar

السلام عليكم
أتفضل أخي ان شاء الله يكون المطلوب
new.rar

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

Sub Send_To_Pdf() Dim PdfPath As String Dim BoDy As String BoDy = "Hellom Officena.net" PdfPath = Save_as_pdf EnvoiMail Right(PdfPath, InStr(1, StrReverse(PdfPath), "\") - 1), " ", , , BoDy, 1, PdfPath End Sub Public Function Save_as_pdf() As String Dim FSO As Object Dim s(1) As String Dim sNewFilePath As String Set FSO = CreateObject("Scripting.FileSystemObject") s(0) = "C:\Users\" & Environ("UserName") & "\Desktop\" & ActiveWorkbook.Name If FSO.FileExists(ActiveWorkbook.FullName) Then     '//Change Excel Extension to PDF extension in FilePath     s(1) = FSO.GetExtensionName(s(0))     If s(1) <> "" Then         s(1) = "." & s(1)         sNewFilePath = Replace(s(0), s(1), ".pdf")         '//Export to PDF with new File Path         ActiveSheet.ExportAsFixedFormat _             Type:=xlTypePDF, _             Filename:=sNewFilePath, _             Quality:=xlQualityStandard, IncludeDocProperties:=True, _             IgnorePrintAreas:=False, OpenAfterPublish:=False     End If Else     '//Error: file path not found     MsgBox "Error: this workbook may be unsaved.  Please save and try again." End If Set FSO = Nothing Save_as_pdf = sNewFilePath End Function Sub EnvoiMail(Subject As String, Destina As String, Optional CCdest As String, Optional CCIdest As String, Optional BoDyTxt As String, Optional NbPJ As Integer, Optional PjPaths As String)   Dim MonOutlook As Object   Dim MonMessage As Object   Set MonOutlook = CreateObject("Outlook.Application")   Set MonMessage = MonOutlook.createitem(0)   Dim PJ() As String   PJ() = Split(PjPaths, ";")   With MonMessage       .Subject = "P.O #" & Subject     '"Je suis content"       .To = Destina           '       .cc = " "            '"chef@machin.com;directeur@chose.com"       .bcc = CCIdest          '"un.copain@supermail.com;une-amie@hotmail.com"       .BoDy = "Hello , Officena.net"         If PjPaths <> "" And NbPJ <> 0 Then             For i = 0 To NbPJ - 1                 'MsgBox PJ(I)               .Attachments.Add PJ(i)      '"C:\Mes Documents\Zoulie Image.gif"             Next i         End If       .display       '.send                        '.Attachments.Add ActiveWorkbook.FullName   End With                        '?plusieurs?MonMessage.Attachments.Add "D:\Prof\Janvier\Base clients.mdb"   Set MonOutlook = Nothing End Sub