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

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