Mharee Accounting Albaig قام بنشر الأحد at 19:26 مشاركة قام بنشر الأحد at 19:26 السلام عليكم اللهم صلي على محمد وال محمد اخواني اشكركم جزيل الشكر على الأهتمام والفائدة للجميع ان شاء الله ارفق لكم هذا الملف يحتاج الى تعديل في خانة السعر العامود B في البيان لتشغيل المحرك ويبحث بالايتم المطلوب حسب الحروف والأسماء وتمنياتي لكم بالموفقية واشكر جميع الأعضاء والمشرفين الكرام فاتورة مبيعات مميزه 3 (1).xlsm رابط هذا التعليق شارك More sharing options...
AmirMohamed قام بنشر منذ 10 ساعات مشاركة قام بنشر منذ 10 ساعات (معدل) طبعا تفضل اخي الكريم بحث متطور ـ بحيث انك تبحث من أي حرف في البيانات ليس فقط بداية البيانات 🙂 وهذا هو الكود المستخدم : 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 تم تعديل منذ 9 ساعات بواسطه AmirMohamed رابط هذا التعليق شارك More sharing options...
Mharee Accounting Albaig قام بنشر منذ 6 ساعات الكاتب مشاركة قام بنشر منذ 6 ساعات اخي العزيز اشكرك جزيل الشكر على هذا الجهد والأبداع ولكن اتمنى ان تركب الكود على الفاتورة حيث اني حملت الفاتورة ولم تعمل ممنون منك رابط هذا التعليق شارك More sharing options...
محمد هشام. قام بنشر منذ 3 ساعات مشاركة قام بنشر منذ 3 ساعات وعليكم السلام ورحمة الله تعالى وبركاته بما انك اخي ترغب بتعبئة الفاتورة عن طريق اليوزرفورم مع إمكانية البحث بالحروف الأولى او اي جزء من الإسم في عمود البيان إليك طريقة أكثر ديناميكية ربما تناسبك Dim TabBD(), OnRng(), a() Private Sub UserForm_Initialize() Dim WS As Worksheet, c As Variant Dim lastRow As Long, dict As Object Set WS = ThisWorkbook.Sheets("Sheet2") lastRow = WS.Cells(WS.Rows.Count, "C").End(xlUp).Row a = WS.Range("C2:C" & lastRow).Value OnRng = Application.Transpose(WS.Range("B2:B" & lastRow).Value) Set dict = CreateObject("Scripting.Dictionary") For Each c In OnRng If Trim(c) <> "" Then dict(c) = "" End If Next c Me.ComboBox1.List = dict.keys End Sub '============ Private Sub Button1_Click() Dim lastRow As Range If Not Intersect(ActiveCell, ThisWorkbook.Sheets("Sheet1").Range("B15:B24")) Is Nothing Then If Me.ComboBox1 <> "" And Me.ComboBox2 <> "" Then ActiveCell.Value = UCase(Me.ComboBox1) If Me.TextBox1 <> "" Then ActiveCell.Offset(, 1).Value = Me.TextBox1.Value End If Unload Me Else MsgBox "يرجى إظافة البيانات", vbInformation Exit Sub End If Else Set lastRow = ThisWorkbook.Sheets("Sheet1").Range("B15:B24").Find(What:="", LookIn:=xlValues) If Not lastRow Is Nothing Then lastRow.Value = UCase(Me.ComboBox1) If Me.TextBox1 <> "" Then lastRow.Offset(, 1).Value = Me.TextBox1.Value End If Unload Me Else MsgBox "لا توجد خلايا فارغة متاحة في الفاتورة", vbInformation Exit Sub End If End If End Sub '=============== Private Sub ComboBox1_Change() If Me.ComboBox1.ListIndex = -1 And IsError(Application.Match(Me.ComboBox1, OnRng, 0)) Then Set dict = CreateObject("Scripting.Dictionary") tmp = "*" & UCase(Me.ComboBox1) & "*" For Each c In OnRng If UCase(c) Like tmp Then dict(c) = "" Next c Me.ComboBox1.List = dict.keys Me.ComboBox1.DropDown Else Search = UCase(Me.ComboBox1) If Search = "" Then Exit Sub ligne = 0 ReDim TabBD(1 To UBound(a)) For i = LBound(a) To UBound(a) If OnRng(i) = Search Then ligne = ligne + 1 TabBD(ligne) = a(i, 1) End If Next i ReDim Preserve TabBD(1 To ligne) Me.ComboBox2.List = TabBD If Me.ComboBox2.ListCount > 0 Then Me.ComboBox2.ListIndex = 0 End If End If End Sub '============ Private Sub ComboBox2_Change() If Me.ComboBox1 <> "" Then If Me.ComboBox2.ListIndex = -1 Then Set dict = CreateObject("Scripting.Dictionary") tmp = UCase(Me.ComboBox2) & "*" For Each c In TabBD If UCase(c) Like tmp Then dict(c) = "" Next c Me.ComboBox2.List = dict.keys Me.ComboBox2.DropDown Else tmp = Application.Match(Me.ComboBox2.Value, TabBD, 0) End If End If End Sub Private Sub ComboBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean) ComboBox1.Value = "" End Sub وفي حدث Sheet1 ضع الكود التالي Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Not Intersect([B15:B24], Target) Is Nothing And Target.Count = 1 Then With UserForm2 .StartUpPosition = 0 .Left = Target.Left + 506 .Top = Target.Top + 30 - Cells(ActiveWindow.ScrollRow, 1).Top .Show End With End If End Sub فاتورة مبيعات مميزه 4.xlsm رابط هذا التعليق شارك More sharing options...
الردود الموصى بها
من فضلك سجل دخول لتتمكن من التعليق
ستتمكن من اضافه تعليقات بعد التسجيل
سجل دخولك الان