AmirMohamed

السلام عليكم كيف الحال فكره سريعة تعرض تنبيهات للسدادات المتأخرة او الالتزامات التي اوشكت على الدفع New Microsoft Excel Worksheet.xlsm

المشكلة يا عزيزي انك عند استدعاء اسم الشيت تستدعيه داخل علامه تنصيص و بجواره A1 ، لذلك تم تعديل بعض الأشياء في هذا الكود لكي يتم استبعاد A1 وعلامه التنصيص Private Sub Workbook_SheetFollowHyperlink(ByVal Sh As Object, ByVal Target As Hyperlink) Dim targetSheetName As String Dim password As String Dim sheetNameParts() As String ' Extract the sheet name from the hyperlink address and trim any spaces targetSheetName = Trim(Target.SubAddress) ' Split the name by the delimiter (usually "!") sheetNameParts = Split(targetSheetName, "!") ' Take only the first part as the sheet name If UBound(sheetNameParts) >= 0 Then targetSheetName = Trim(sheetNameParts(0)) End If ' Remove any single quotes from the sheet name targetSheetName = Replace(targetSheetName, "'", "") ' Debugging: Print the target sheet name to the Immediate Window Debug.Print "Target Sheet Name: " & targetSheetName ' Ask for password password = InputBox("Enter the password to access this sheet: " & targetSheetName) ' Check if the target sheet is available and the password is correct If LCase(targetSheetName) = LCase("Hassen Barrah") And password = "50" Then UnhideAndUnprotectSheet targetSheetName Else MsgBox "Incorrect password. The sheet will remain hidden.", vbCritical End If End Sub هذا الملف بعد التعديل تحياتي Lesson plan V1 Draft.xlsm

عشان تقدر تطبق المطلوب كان لابد من عمد كود برمجة فيه داله اسمها MaxNumber تعمل المطلوب وبشكل مختصر هذا كود البرمجة: Function MaxNumber(rng As Range) As Double Dim cell As Range Dim matches As Object Dim largest As Double Dim regex As Object Set regex = CreateObject("VBScript.RegExp") regex.Global = True regex.IgnoreCase = True regex.Pattern = "\d+(\.\d+)?" largest = -1 For Each cell In rng If Not IsEmpty(cell.Value) Then Set matches = regex.Execute(cell.Value) If matches.Count > 0 Then Dim match As Variant For Each match In matches If CDbl(match.Value) > largest Then largest = CDbl(match.Value) End If Next match End If End If Next cell MaxNumber = largest End Function بعد كده اختار أي عمود تحتاجه عادي جدا زي ما بتعمل أي معادلة وهذه المعادلة كده بتكون : =MaxNumber(A1:A100) تحياتي 🙂 اكبر قيمه.xlsm

طيب تمام بجرب طريقه اخرى

=MAX(IF(ISNUMBER(VALUE(LEFT(A1:A100; LEN(A1:A100)-1))); VALUE(LEFT(A1:A100; LEN(A1:A100)-1)); 0)) جرب هذي المعادلة اكبر قيمه.xlsx

تمام وضحت الفكرة ، اليك المرفق بكود جديد وبه بعض التنسيقات ان شاء الله تعجبك Private Sub CommandButton1_Click() Dim wsSource As Worksheet Dim wsDest As Worksheet Dim lastRow As Long Dim destRow As Long Dim dateFrom As Date Dim dateTo As Date Dim i As Long Dim headerRange As Range Dim tableRange As Range Set wsSource = ThisWorkbook.Sheets("ورقة1") Set wsDest = ThisWorkbook.Sheets("ورقة2") dateFrom = CDate(TextBox1.Value) dateTo = CDate(TextBox2.Value) lastRow = wsSource.Cells(wsSource.Rows.Count, "F").End(xlUp).Row destRow = 1 wsSource.Range(wsSource.Cells(1, 2), wsSource.Cells(1, wsSource.Columns.Count).End(xlToLeft)).Copy _ Destination:=wsDest.Cells(destRow, 2) wsDest.Cells(destRow, 1).Value = "م" wsDest.Cells(destRow, 1).Font.Bold = True wsDest.Cells(destRow, 1).Font.Size = 18 wsDest.Cells(destRow, 2).Resize(1, wsSource.Columns.Count - 1).Font.Bold = True wsDest.Cells(destRow, 2).Resize(1, wsSource.Columns.Count - 1).Font.Size = 18 destRow = destRow + 1 For i = 2 To lastRow If wsSource.Cells(i, 6).Value >= dateFrom And wsSource.Cells(i, 6).Value <= dateTo Then wsSource.Range(wsSource.Cells(i, 2), wsSource.Cells(i, wsSource.Columns.Count).End(xlToLeft)).Copy _ Destination:=wsDest.Cells(destRow, 2) wsDest.Cells(destRow, 1).Value = destRow - 1 wsDest.Cells(destRow, 1).Font.Size = 16 wsDest.Cells(destRow, 2).Resize(1, wsSource.Columns.Count - 1).Font.Size = 16 destRow = destRow + 1 End If Next i Set headerRange = wsDest.Range(wsDest.Cells(1, 1), wsDest.Cells(1, 7)) headerRange.Interior.Color = RGB(0, 102, 204) headerRange.Font.Color = RGB(255, 255, 255) wsDest.Columns("A").AutoFit wsDest.Columns("B").Resize(, wsSource.Columns.Count - 1).AutoFit Set tableRange = wsDest.Range(wsDest.Cells(1, 1), wsDest.Cells(destRow - 1, 7)) With tableRange.Borders .LineStyle = xlContinuous .Weight = xlThin .Color = RGB(173, 216, 230) End With MsgBox "تم فلترة البيانات بنجاح!" End Sub وفي كود الحذف بتضيف سطر كمان Private Sub CommandButton2_Click() On Error Resume Next sh2.Range("a1").CurrentRegion.Delete sh2.Range("a1").CurrentRegion.Clear End Sub اليك المرفق به التعديلات ♥ الدرس 259 (1).xlsm

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

يعمل معي بشكل صحيح ، اعتقد المشكلة لازم تفعل بعض المكتبات انتقل إلى قائمة Tools ثم اختر References واختار نفس الموجود في الصوره

اتمني اكون سددت المطلوب Sub DeleteRows() Dim ws As Worksheet Set ws = ThisWorkbook.Sheets("ورقة1") Dim response As VbMsgBoxResult response = MsgBox("هل أنت متأكد أنك تريد نقل البيانات وحذفها من الجدول الأساسي؟", vbYesNo + vbQuestion, "تنبيه") If response = vbNo Then Exit Sub End If Dim lastRow As Long Dim lastRow1 As Long lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row lastRow1 = ws.Cells(ws.Rows.Count, "F").End(xlUp).Row ws.Range("F3:J" & lastRow1).Clear ws.Range("A2:D" & lastRow).Copy ws.Range("G2").PasteSpecial Paste:=xlPasteAll ws.Range("A3:D" & lastRow).Clear ws.Range("F1:J1").Merge ws.Range("F1").Value = ws.Cells(1, 1).Value ws.Range("F1").NumberFormat = "dddd dd - mm - yyyy" With ws.Range("F1") .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .Font.Size = 18 .Font.Bold = True .Interior.Color = RGB(217, 217, 217) End With With ws.Range("F2:J2") .Interior.Color = RGB(217, 217, 217) .Font.Size = 16 .Font.Bold = True .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter End With With ws.Range("G3:J" & lastRow) .Font.Size = 16 .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter End With ws.Cells(2, "F").Value = "ت" Dim i As Long For i = 3 To lastRow ws.Cells(i, "F").Value = i - 2 Next i ws.Range("F2:F" & lastRow).Borders.LineStyle = xlContinuous ws.Range("F2:F" & lastRow).HorizontalAlignment = xlCenter ws.Range("F2:F" & lastRow).VerticalAlignment = xlCenter ws.Columns("F").ColumnWidth = 6 ws.Columns("G").ColumnWidth = 16.88 ws.Columns("H").ColumnWidth = 19.68 ws.Columns("I").ColumnWidth = 19.38 ws.Columns("J").ColumnWidth = 8.5 Application.CutCopyMode = False ws.Cells(1, 1).Value = ws.Cells(1, 1).Value + 1 End Sub عمل تنسيقات بعد الضغط على الزر.xlsm

تفضل اخي الحبيب وهذه المعادلة المستخدمة : =IF(B3<>""; SUBTOTAL(3; $B$2:B3); "") اما عن فيجوال فيجوال بيسك نحتاج السورس كود للمشروع لكي يتم عمل الكود اللازم له box (1).xlsm

أي اصدار اوفيس تستخدم اخي الكريم ؟

تمام اخي الكريم تفضل وهذه المعادلة المستخدمة : =IF($C$2<>"";TRANSPOSE(IFERROR(INDEX(UNIQUE(FILTER($B:$B; $A:$A = $C$2)); ROUNDUP(COLUMN(A1)/2; 0)); ""));"") HHA (1).xlsx

تفضل اخي المطلوب ان شاء الله تم اضافه فورم جديد ايضا يسهل عمليات البحث تستدعي الفورم الجديد عند الضغط على دبل كليل في Textbox1 وعند العثور على البحث في الفورم الجديد تضغط ايضا دبل كليل في listview يرحل رقم الحساب ايضا في فورم 2 اتمني تعجبك الفكره ! ملاحظه: اذا لم يعمل معك بشكل جيدا يجب عليك تحميل اداة Microsoft Windows Common Controls 6.0 SP6 حتي تتمكن باستخدام اداة listview تحياتي لحضرتك ____برنامج المعطل ver 20 2024 مثال.xlsm

وعليكم السلام تفضل اخي الملف في المرفقات وهذي المعادلة المستخدمة : =IF(C2<>"";TRANSPOSE(UNIQUE(FILTER(B:B; A:A = C2)));"") HHA.xlsx

جرب هذه الطريقه

وعليكم السلام ورحمه الله وبركاته ارجو وضع نسخه من الشيت لعمل اللازم

Sub printpreview1() On Error GoTo ErrorHandler ThisWorkbook.Windows(1).Visible = True Application.Visible = True Dim lastRow As Long Dim ws As Worksheet ' تحديد ورقة العمل المطلوبة Set ws = ThisWorkbook.Sheets("sheet") ' العثور على آخر صف يحتوي على بيانات lastRow = ws.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row If lastRow > 0 Then ' إعداد منطقة الطباعة لتشمل كل الأعمدة With ws .PageSetup.PrintArea = .Cells(1, 1).Resize(lastRow, ws.Columns.Count).Address .PrintPreview End With End If Exit Sub ErrorHandler: MsgBox "حدث خطأ: " & Err.Description, vbExclamation, "خطأ" End Sub تمام تفضل اخي الكريم

طبعا تفضل اخي الكريم بحث متطور ـ بحيث انك تبحث من أي حرف في البيانات ليس فقط بداية البيانات 🙂 وهذا هو الكود المستخدم : Private Sub Find_T() Dim ws As Worksheet Dim searchRange As Range Dim cell As Range Dim searchText As String Dim rowValues As Variant Dim i As Integer Dim j As Integer Dim dict As Object Dim rowKey As String Dim numCols As Integer Dim columnWidths As String Dim tempList As Collection Dim finalList() As Variant Dim rowCount As Integer Dim rowHeight As Integer Dim maxVisibleRows As Integer Dim listBoxHeight As Integer Dim maxListBoxHeight As Integer ' تعيين ارتفاع الصف الواحد (يمكنك تعديله حسب الحاجة) rowHeight = 15 ' الحصول على النص الذي تم إدخاله في ComboBox searchText = Trim(CM_TextFind.Text) ' إذا كان النص فارغًا، اجعل الـ ListBox غير مرئي واخرج من الدالة If Len(searchText) = 0 Then Me.CM_ListFind.Visible = False Exit Sub End If ' إعداد معجم لتخزين الصفوف المضافة وتجنب التكرار Set dict = CreateObject("Scripting.Dictionary") Set tempList = New Collection ' تحديد ورقة العمل ونطاق البحث Set ws = ThisWorkbook.Sheets("Sheet2") ' غيّر اسم الورقة إذا لزم الأمر Set searchRange = ws.Range("b2:c1000") ' غيّر النطاق بناءً على بياناتك ' مسح محتويات ListBox CM_ListFind.Clear ' تحديد عدد الأعمدة في ListBox بناءً على نطاق البيانات numCols = searchRange.Columns.Count CM_ListFind.ColumnCount = numCols ' تعيين عرض الأعمدة columnWidths = Join(Application.Transpose(Application.Transpose(Array(100, 20))), ";") CM_ListFind.columnWidths = columnWidths ' البحث عن النص في كل خلية بالنطاق وإضافة الصفوف المتطابقة إلى Collection For Each cell In searchRange.Rows If Len(searchText) > 0 Then rowValues = cell.Value rowKey = Join(Application.Index(rowValues, 1, 0), Chr(0)) ' تحقق من وجود النص في أي خلية من الصف For i = 1 To UBound(rowValues, 2) If InStr(1, rowValues(1, i), searchText, vbTextCompare) > 0 Then ' إضافة الصف إلى Collection إذا لم يكن موجودًا بالفعل If Not dict.Exists(rowKey) Then dict.Add rowKey, Nothing ' إضافة الصف إلى Collection tempList.Add rowValues End If Exit For ' لا حاجة للتحقق من باقي الأعمدة في هذا الصف End If Next i End If Next cell ' تحويل Collection إلى مصفوفة ثنائية الأبعاد If tempList.Count > 0 Then ReDim finalList(1 To tempList.Count, 1 To numCols) rowCount = 0 For Each rowValues In tempList rowCount = rowCount + 1 For j = 1 To numCols finalList(rowCount, j) = rowValues(1, j) Next j Next rowValues ' تعيين البيانات من المصفوفة النهائية إلى ListBox CM_ListFind.List = finalList ' حساب عدد الصفوف القابلة للعرض بناءً على ارتفاع النموذج maxVisibleRows = Int(Me.InsideHeight / rowHeight) - 1 ' تعديل ارتفاع الـ ListBox بناءً على عدد الصفوف If tempList.Count < maxVisibleRows Then listBoxHeight = tempList.Count * rowHeight Else listBoxHeight = maxVisibleRows * rowHeight End If ' تعيين الحد الأقصى لارتفاع الـ ListBox (يمكنك تعديله حسب الحاجة) maxListBoxHeight = 300 ' تحديد قيمة مناسبة للارتفاع الأقصى للـ ListBox ' التأكد من أن ارتفاع الـ ListBox لا يتجاوز الحد الأقصى If listBoxHeight > maxListBoxHeight Then listBoxHeight = maxListBoxHeight End If ' تعيين ارتفاع الـ ListBox CM_ListFind.Height = listBoxHeight ' التأكد من عرض الـ ListBox Me.CM_ListFind.Visible = True Else ' إذا لم يكن هناك بيانات، اجعل الـ ListBox غير مرئي Me.CM_ListFind.Visible = False End If ' إضافة تأخير بسيط للتأكد من أن البيانات تم تحميلها بشكل كامل DoEvents End Sub فاتورة مبيعات مميزه 3 (1).xlsm

تفضل اخي الكريم هذا كود يظهر المعاينه وايضا بعد اغلاق المعاينه يظهر رساله تخيير تصدر اكسل او PDF 🙂 أنشئ موديول وضيف فيه هذا الكود : Sub printpreview1() ThisWorkbook.Windows(1).Visible = True Application.Visible = True Dim lastRow As Long Dim lastColumn As Long Dim ws As Worksheet Dim response As VbMsgBoxResult ' تحديد ورقة العمل المطلوبة Set ws = ThisWorkbook.Sheets("sheet") ' العثور على آخر صف وعمود يحتويان على بيانات lastRow = ws.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row lastColumn = ws.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column If lastRow > 0 And lastColumn > 0 Then ' إعداد منطقة الطباعة With ws .PageSetup.PrintArea = .Cells(1, 1).Resize(lastRow, lastColumn).Address .PrintPreview End With ' عرض رسالة خيارات التصدير Dim exportChoice As Integer exportChoice = MsgBox("اختر نوع التصدير:" & vbCrLf & _ "نعم - تصدير إلى Excel" & vbCrLf & _ "لا - تصدير إلى PDF" & vbCrLf & _ "إلغاء - للخروج", _ vbYesNoCancel + vbQuestion, "تصدير البيانات") Select Case exportChoice Case vbYes ' تصدير إلى Excel Dim newWorkbook As Workbook Set newWorkbook = Workbooks.Add ws.Cells.Copy Destination:=newWorkbook.Sheets(1).Cells(1, 1) Dim excelPath As String excelPath = Application.GetSaveAsFilename(InitialFileName:=".xlsx", FileFilter:="Excel Files (*.xlsx), *.xlsx") If excelPath <> "False" Then newWorkbook.SaveAs excelPath MsgBox "تم تصدير البيانات بنجاح إلى Excel!" Else MsgBox "تم إلغاء عملية التصدير" End If newWorkbook.Close SaveChanges:=False Case vbNo ' تصدير إلى PDF Dim pdfPath As String pdfPath = Application.GetSaveAsFilename(InitialFileName:="Document.pdf", FileFilter:="PDF Files (*.pdf), *.pdf") If pdfPath <> "False" Then ws.ExportAsFixedFormat Type:=xlTypePDF, Filename:=pdfPath, Quality:=xlQualityStandard MsgBox "تم تصدير البيانات بنجاح إلى PDF!" Else MsgBox "تم إلغاء عملية التصدير" End If Case vbCancel MsgBox "تم إلغاء عملية التصدير" End Select Else MsgBox "لا توجد بيانات للتصدير." End If End Sub

جرب هذا الكود اخي =IF(TODAY()>G3;INT((DATEDIF(G3; TODAY(); "m") / 4) * 10);"لم يأتي الموعد")

نعم اخي لاني عوضت رقم السند في ليبل بدل من تيكست ونسيت احذف كود تفريغ تيكست بوكس 10 ، لذلك تم ازالة كود التفريغ جزاك الله خير تم وضع المرفق في اول مشاركة واذا وجد مشكله اخرى ارجو افادتنا بها

شكرا اخي العزيز لارفاق الملف بدل وضع رابط له 🙂

محاسبة.zipالسلام عليكم ورحمه الله وبركاته حالياً أعمل على تطوير برنامج محاسبي وقد استعنت كثيراً بموقعنا المتميز اوفيسنا للحصول على معلومات ودعم أود أن أطلب النصائح و المساعدة والتعاون منكم لاستكمال المشروع. شكراً جزيلاً لكل من ساهم في هذا الموقع والله يجزيكم كل خير كلمه السر 1234 لا تنسوا الغاء الحظر ان وجد الحمد لله انتهيت من المحاسبه الماليه كاملا بالتقارير اللازمه وباقي اضيف مديول للمبيعات والمشتريات والمخزون ان شاء الله 🙂 تم رفع الملف في المنتدي لتمام الاستفاده محاسبة.zip

السلام عليكم ورحمه الله وبركاته اخواني الكرام اسعد الله اوقاتكم بكل خير حبيت اشارك معكم هذا الملف واخذ راي حضراتكم في هذه الفكره واحتاج من حضراتكم المساعده في تطوير الفكره هذه باضافه طرق الدفع عن طريق الكاش او بنك واضافه مناديب واقدر ايضا استعلم عن رصيد كل عميل او مندوب واضافه خانه لدعم المالك ومسحوباته بحيث اقدر اضيف تابات جديده في الفورم للاستعلامات الملف مساحته اكبر من حد المفرقات لذلك بضعه على رابط تحميل https://www.mediafire.com/file/q9rov0o3tma0ssp/حسابات.xlsm/file الله يوفقنا جميعا ♥

السلام عليكم ..تفضل اخي الكريم ما عليك فقط غير ان اول خانه تكتب رقم الشهر فقط و الخانة الثانية في التاريخ تذكر اول يوم من اول تاريخ في السنه الحالية ..تحياتي ♥ موعد الرواتب.xlsx