تعديل محرك البحث عن السلعة

[Mharee Accounting Albaig]

السلام عليكم 

اللهم صلي على محمد وال محمد 

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

وتمنياتي لكم بالموفقية

واشكر جميع الأعضاء والمشرفين الكرام 

 

 

فاتورة مبيعات مميزه 3 (1).xlsm

[AmirMohamed]

طبعا تفضل اخي الكريم بحث متطور ـ بحيث انك تبحث من أي حرف في البيانات ليس فقط بداية البيانات 🙂 

وهذا هو الكود المستخدم :

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

تم تعديل سبتمبر 30 بواسطه AmirMohamed

[Mharee Accounting Albaig]

اخي العزيز اشكرك جزيل الشكر على هذا الجهد والأبداع 

ولكن اتمنى ان تركب الكود على الفاتورة حيث اني حملت الفاتورة ولم تعمل 

ممنون منك 

[محمد هشام.]

وعليكم السلام ورحمة الله تعالى وبركاته 

بما انك اخي ترغب بتعبئة الفاتورة عن طريق اليوزرفورم مع إمكانية البحث بالحروف الأولى او اي جزء من الإسم  في عمود البيان إليك طريقة أكثر ديناميكية ربما تناسبك 

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