نجوم المشاركات

وعليكم السلام ورحمة الله تعالى وبركاته المفروض اخي @Alaa Ammar New ورقة الاشطة خاصة بفلترة البيانات بين تاريخين يتم تحديدهم مسبقا في الخلية D2 و F2 بمعنى انت من تحدد البيانات الظاهرة عليها .في حالة الرغبة بجلب جميع البيانات يمكنك فقط تحديد اول واخر تاريخ لديك على Sheet1 يمكنك اظافة الكود التالي في حدث Sheet1 ليتم تحديث التسلسل تلقائيا . Private Sub Worksheet_Change(ByVal Target As Range) Dim sht As Worksheet: Set sht = Sheets("Sheet1") If Target.Column = 1 Then Application.ScreenUpdating = False Application.EnableEvents = False sht.Range("A9:A" & sht.Rows.Count).ClearContents sht.[A9].Value = 1 With sht.Range("A9:A" & sht.Cells(sht.Rows.Count, "C").End(xlUp).Row) .Formula = "=Row() - 8" .Value = .Value End With Application.EnableEvents = True Application.ScreenUpdating = True End If End Sub Dim desWS As Worksheet: Set desWS = Sheets("Sheet1") Dim dest As Worksheet: Set dest = printing Application.ScreenUpdating = False If Sheets("Sheet1").TextBox1.Text = "" Then: MsgBox "يرجى اظافة معيار الفلترة": Exit Sub rng = Application.WorksheetFunction.Subtotal(3, desWS.Range("L9:L10000")) If rng = 0 Then: MsgBox "لا توجد بيانات للحفظ", _ vbInformation, "تم إلغاء الإجراء": Exit Sub dest.Visible = xlSheetVisible Set a = desWS.Range("A7", desWS.Range("A" & desWS.Rows.Count).End(xlUp)) For r = 1 To 12 Set a = Union(a, Intersect(a.EntireRow, a.Columns(r))) Next r Msg = MsgBox("؟" & " " & "PDF " & ":" & " تصدير التقرير بصيغة", vbYesNo, dest.Name) If Msg <> vbYes Then Exit Sub dest.Range("A2:L" & dest.Rows.Count).Clear a.Copy Destination:=dest.Range("A6") dest.Range("a8").Value = 1 With dest.Range("a8:a" & dest.Cells(dest.Rows.Count, "B").End(xlUp).Row) .Formula = "=Row() - 7" .Value = .Value End With 'حفظ PDF Save_As_PDF2 On Error Resume Next desWS.AutoFilter = False Sheets("Sheet1").TextBox1.Text = "" Application.ScreenUpdating = True 2024 final.xlsm

برنامج تصنيع محطة خرسانة.xlsb

تفضل استاذ @أمير ادم هذا المرفق لأحد بالمنتدى ام اتذكر اسمه وهو بسيط . Import Frome Excel File.rar

الأستاذة / حنان الأخوة الكرام تحية طيبة وبعد ،،، كما فهمت المطلوب هو دالة لتغير مقاس الصورة الدالة المستخدمة هي WIA_ResizeImage وهذه الدالة تقوم بتغير أبعاد الصورة بـ البكسل PIXEL والبكسلز تتغير بثلاث عوامل الطول والعرض والجودة لذا يجب العلم ان عند تحويل المقاس إلي 8.5 سم × 11 سم يجب أن يتم تحديد أيضاً الجودة المطلوبة والصور التالية توضح الأمر والان نأتي الي الأكواد 1- الاكواد المساعدة للتحويل من MM / CM / INCH إلي PIXELS يجب وضعها في بداية مديول جديد Option Explicit Public Enum convertFrom cm mm inch End Enum Public Enum qualityRes q72PPI = 72 q96PPI = 96 q150PPI = 150 q200PPI = 200 q300PPI = 300 End Enum Public Function ConvertToPixels(Value As Double, unit As convertFrom, resolution As qualityRes) As Double Dim inches As Double Dim finalResolution As Double If Value < 0 Then Debug.Print "ConvertToPixels", "Measurement value must be non-negative." ConvertToPixels = 0 Exit Function End If Select Case unit Case convertFrom.cm inches = Value / 2.54 Case convertFrom.mm inches = Value / 25.4 Case convertFrom.inch inches = Value Case Else Debug.Print "ConvertToPixels", "Invalid unit" ConvertToPixels = 0 Exit Function End Select finalResolution = resolution ConvertToPixels = inches * finalResolution End Function كما يمكن استخدام هذا الموقع للتحويل https://www.aspect-ratios.com/pixel-calculator/ كود التجربة Sub test_ChangeImageSize() Dim sourceImgPath As String Dim targetImgPath As String Dim imgWidth As Double Dim imgHight As Double Dim pxlWidth As Long Dim pxlHight As Long Dim keepAspectRatio As Boolean Dim overWrtieTargetFile As Boolean sourceImgPath = "C:\Users\user\Downloads\Compressed\Cropping an Image With Controll Print v.1\Images\4130001.jpg" targetImgPath = "C:\Users\user\Downloads\Compressed\Cropping an Image With Controll Print v.1\Images\4130001_2.jpg" imgWidth = 8.5 imgHight = 11 keepAspectRatio = False overWrtieTargetFile = True pxlWidth = Round(ConvertToPixels(imgWidth, cm, q300PPI), 0) pxlHight = Round(ConvertToPixels(imgHight, cm, q300PPI), 0) If WIA_ResizeImage(sourceImgPath, targetImgPath, pxlWidth, pxlHight, keepAspectRatio, overWrtieTargetFile) Then Debug.Print "Your Image Resized Successfully" Else Debug.Print "Something Went Wrong !" End If End Sub هذا الإختيار للحفاظ علي تناسق ابعاد الصورة وبالطبع انم لم تكن الابعاد المستخدمة متناسقة فستختلف النتيجة لذا تم عمله هكذا حتي تخرج الصورة بالأبعاد المحددة keepAspectRatio = False وهذا الاختيار للكتابة فوق الملف الجديد إذا كان موجود بالفعل overWrtieTargetFile = True بالتوفيق

شكرا جزيلا أخي الفاضل وبارك الله فيك وجعله في ميزان حسناتك بحق هذه الأيام المباركة معلش أنا آسف بتعب حضرتك معاي

اعتذر ................ تفضل المرفق mas_s2 - edit(KK1960)-2.rar

تفضل أخي الكريم الملف مع التطبيق علي الكود الأساسي والبحث باسم من خلال النموذج يمكنك التجربة وفي انتظار وملاحظاتك وتعديلاتك بالتوفيق Smart_Search_Pages_V2.zip

أبدأ من حيث انتهيت الدالة الان تطابق وتبحث عن رقم الصفحة قبل او بعد الـ - يمكن ان نجعل الدالة تطابق النتائج القريبة فقط أي بعد الجزء و الفاصل فقد كنت أفكر في هذا الأمر والحمد لله تم التعديل علي الدالة إليك الدالة الجديدة ومثال عليها Public Function isBookInTextPageNum(ByVal fullText As String, _ ByVal BookName As String, _ ByVal partNum As String, _ ByVal pageNum As String, _ Optional exactPartOnly As Boolean = True, _ Optional Nearest As Boolean = True) As Boolean On Error GoTo ErrorHandler Dim regex As Object Dim matches As Object Dim match As Object Dim pattern As String Set regex = CreateObject("VBScript.RegExp") If exactPartOnly Then If Nearest Then pattern = "(?:" & BookName & "\s*[|_/\\ -]*\s*[\s*|'\(\[\{""]*" & partNum & "\s*[;¡`,|_/\\ -]*\s*[;¡`,|'\(\[\{""]*" & pageNum & ")" Else pattern = "(?:" & BookName & "\s*[|_/\\ -]*\s*[\s*|'\(\[\{""]*" & partNum & "\s*[;¡`,\d|_/\\ -]*\s*[;¡`,\d|'\(\[\{""]*" & pageNum & ")" End If Else If Nearest Then pattern = "(?:" & BookName & "\s*[|_/\\ -]*\s*[\s*|'\(\[\{""]*" & partNum & "\s*[;¡`,|_/\\ -]*\s*[;¡`,|'\(\[\{""]*" & pageNum & "\s*[|_/\\ -]*\s*[|'\)\(\[\{""]*" & ")" Else pattern = "(?:" & BookName & "\s*[|_/\\ -]*\s*[\s*|'\(\[\{""]*" & partNum & "\s*[;¡`,\d|_/\\ -]*\s*[;¡`,\d|'\(\[\{""]*" & pageNum & "\s*[\d|_/\\ -]*\s*[|'\)\(\[\{""]*" & ")" End If End If With regex .Global = False .MultiLine = True .IgnoreCase = False .pattern = pattern End With Set matches = regex.Execute(fullText) If Not matches Is Nothing And matches.count > 0 Then ' Debug.Print "Book(s) found in text:" ' For Each match In matches ' Debug.Print "Found : " & match.Value ' Next isBookInTextPageNum = True Else isBookInTextPageNum = False End If CleanAndExit: If Not regex Is Nothing Then Set regex = Nothing If Not matches Is Nothing Then Set matches = Nothing Exit Function ErrorHandler: Debug.Print "Error: " & Err.Description isBookInTextPageNum = False Resume CleanAndExit End Function إذا أردت طباعة النتائج وقت الاختبار فقط قم بتفعيل هذا الجزء داخل الدالة بحذف علامة ' ' Debug.Print "Book(s) found in text:" ' For Each match In matches ' Debug.Print "Found : " & match.Value ' Next الان كود التجربة والنتائج Sub Test_isBookInTextPageNum() Dim fullText As String Dim BookName As String Dim partNum As String Dim pageNum As String Dim result As Collection Dim match As Variant fullText = "The text includes book names and parts such as: bookName (1 \ 100 - 200 , 100-140), bookName (2 \ 150)." BookName = "bookName" partNum = "1" pageNum = "100" Debug.Print "------------------------------------" Debug.Print isBookInTextPageNum(fullText, BookName, partNum, pageNum, True, True) Debug.Print "------------------------------------" Debug.Print isBookInTextPageNum(fullText, BookName, partNum, pageNum, False, True) Debug.Print "------------------------------------" Debug.Print isBookInTextPageNum(fullText, BookName, partNum, pageNum, True, False) Debug.Print "------------------------------------" Debug.Print isBookInTextPageNum(fullText, BookName, partNum, pageNum, False, False) Debug.Print "------------------------------------" End Sub الان النتائج هي: ------------------------------------ Book(s) found in text: Found : bookName (1 \ 100 True ------------------------------------ Book(s) found in text: Found : bookName (1 \ 100 - True ------------------------------------ Book(s) found in text: Found : bookName (1 \ 100 - 200 , 100 True ------------------------------------ Book(s) found in text: Found : bookName (1 \ 100 - 200 , 100-140) True ------------------------------------ فقد قمت بإضافة للدالة تتيح الاختيار بين أربع احتمالات باستخدامهم معاً Optional exactPartOnly As Boolean = True هذا يخبر الدالة ان تقف عن وجود تطابق ام تكمل حتي أخر ( Optional Nearest As Boolean = True وهذا يخبرها ان تقف عند أقرب نتيجة ام تكمل لو أمكنك التجربة بالمثال السابق وتغير الأرقام وتخبرني أي اختيار نستخدم وللعلم إذا قمت بتعديلات التالية ستجد ان الدالة تعود بجميع النتائج المطابقة من داخل النص وهذا لن يفيد في طريقة الاستخدام الحالية ولكن يمكن استخدامها لاحقاً داخل الدالة نعدل التالي With regex .Global = True .MultiLine = True .IgnoreCase = False .pattern = pattern End With تم تغير من .Global = False إلي .Global = True والان نذهب للمثال ونعدل النص إلي fullText = "The text includes book names and parts such as: bookName (1 \ 100 - 200 , 100-140), bookName (1 \ 100)." ونكمل حديثنا بعد تجربة أخرى إن شاء الله

شكرااااااااااا جداااااااااااااااااااا ربنا يبارك فيكم

ده الحل والله اعلممعرفه الفرق بين الاسمين2.xls

السلام عليكم ورحمة الله وبركاته بسم الله الرحمن الرحيم وبه نستعين أخي الكريم فضلاً قم بتجربة الملف المرفق لدي بعض الأسئلة 1- فيما يخص الـ allFoundMNO فقد لا يتم تسجيلهم جميعاً وذلك لسبب كما في هذه الصورة ستجد ان نتائج البحث 5 ولكن الأرقام التي تم تسجيلها تختلف وذلك لان في هذا الجزء من الكود إذا وجد نتيجة مطابقة يتوقف عن البحث وإذا اردنا ان لا يتوقف حتي نسجل كل النتائج علينا ان نأخذ في الاعتبار - الوقت - هل نريد ان يتم تسجيل اول نتيجة مطابقة او أخر نتيجة في foundMNO وهو يحمل القيمة التي سيتم وضعها في MNO 2- عند المراجعة وجدت هذه الحالة وأردت السؤال عنها الأمر هنا ان اسم الكتاب مختلف فاذا كان الاسم الذي تم استخدامه في اول بحث هو الأربعين للبكري فستظهر النتيجة الاولي فقط أقصد انه لن يتم رصد بدائل كما ان آلية البحث تعتمد أن الخلية في العمود MNO تكون فارغه فاذا كان هناك نتيجة مسجلة فلن تبحث باسم الكتاب الموجود في BookName2 1- في انتظار مراجعتك وملاحظاتك وكيف تريد ان يتم تعديل آلية البحث حتي توفر لك أفضل نتيجة ممكنة 2- هل تملك الصفحات كاملة داخل قاعدة البيانات ؟ بالتوفيق Smart_Search_Pages_V1.zip

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي ضع الكود التالي في Module Function arr(a, b) maxtab1 = UBound(a) Dim tmp(): ReDim tmp(1 To UBound(a) + UBound(b), 1 To UBound(a, 2)) For i = LBound(a) To UBound(a) For c = 1 To UBound(a, 2): tmp(i, c) = a(i, c): Next Next i For i = 1 To UBound(b) For c = 1 To UBound(b, 2): tmp(maxtab1 + i, c) = b(i, c): Next Next i arr = tmp End Function وفي داخل اليوزرفورم Dim rng(), Cnt, Width, OneRng, ColVisu '09/06/2024 by:MOHAMEED HICHAM www.officena.net "منتدى الاكسيل" ' Private Sub UserForm_Initialize() Dim Cpt, F Cpt = [Data]: F = [Data1]: rng = arr(Cpt, F) 'Merge table data For i = LBound(rng) To UBound(rng): rng(i, 2) = Format(rng(i, 2), "dd/mm/yyyy"): Next i OneRng = "Data" Width = Array(100, 80, 80, 160, 80, 60) ColVisu = Array(6, 5, 4, 3, 2, 1): Cnt = UBound(ColVisu) + 1 For c = 1 To Cnt tmp = Range(OneRng).Offset(-1).Item(1, c) Me("Label" & c).Caption = tmp: Me("Labtxt" & c).Caption = tmp Next txtClear Me.ListBox1.ColumnCount = Cnt Me.ListBox1.ColumnWidths = Join(Width, ";") Dim result(): n = 0 For i = 1 To UBound(rng) n = n + 1: ReDim Preserve result(1 To Cnt, 1 To n) c = 0 For Each k In ColVisu c = c + 1: result(c, n) = rng(i, k) Next k Next i If n > 0 Then Me.ListBox1.Column = result: Counter = ListBox1.ListCount Else Me.ListBox1.Clear End If End Sub '***************** Sub filterdata() Dim result(): n = 0 Dim Cpt1 As String, Cpt2 As String For i = 1 To UBound(rng) 'الاسم If TextBox1.Value = "" Then Cpt1 = rng(i, 3) Else Cpt1 = "*" & TextBox1.Value & "*" 'رقم المعاملة If TextBox2.Value = "" Then Cpt2 = rng(i, 6) Else Cpt2 = "*" & TextBox2.Value & "*" If LCase(rng(i, 3)) Like LCase(Cpt1) And LCase(rng(i, 6)) Like LCase(Cpt2) Then n = n + 1: ReDim Preserve result(1 To Cnt, 1 To n) c = 0 For Each r In ColVisu c = c + 1: result(c, n) = rng(i, r) Next r End If Next i If n > 0 Then Me.ListBox1.Column = result Counter = ListBox1.ListCount Else Me.ListBox1.Clear End If txtClear End Sub '*********************** Private Sub TextBox1_Change() Call filterdata End Sub Private Sub TextBox2_Change() Call filterdata End Sub Private Sub ListBox1_Click() For i = 1 To Cnt Me("txt" & i) = Me.ListBox1.Column(i - 1) Next i End Sub '********************* Private Sub transfert_Click() Set WS = Sheets("Sheet1") WS.Cells.ClearContents n = ListBox1.ListCount: result = Me.ListBox1.List WS.[A2].Resize(n, 6) = Application.Index(result, _ Evaluate("Row(1:" & n & ")"), ColVisu) c = 0 For c = 1 To Cnt WS.Cells(1, c) = Range(OneRng).Offset(-1).Item(1, c) Next Me.TextBox1 = "": Me.TextBox2 = "" MsgBox "تم ترحيل البيانات بنجاح", Exclamation, "admin" End Sub '************************* Sub txtClear() For k = 1 To Cnt Me("txt" & k) = "" Next k End Sub كشف المعاملات المؤرشفة.xlsb

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

السلام عليكم ورحمه الله وبركاته اذا كان هذا ما تريد فمن فضلك قيم اجابتى وشكرا لك تغير تاريخ بناء على قيمه كمبوبوكس.accdb

سامحني استاذ @بكيل الشوكي حاولت لكن اللغة العربية بالاسماء ( الجداول- الاستعلامات-النماذج -.............. ) ترهق نظري جداً . ويمكن يكون أحد اسباب تأخر الأخوة أيضاً (لخبطة البرمجة بسبب اللغة العربية) .