كود بحث

[Hasan-hasan]

السلام عليكم 

حياكم الله اساتذتي الكرام 

لدي مشكلة اذا ممكن المساعدة عند البحث بالاسم او الرمز يستغرق وقت من الزمن والانتظار هل مشكلة في الكود ام هناك كود برمجي لتقليل الزمن 

وسأرفق ملف العمل للاطلاع ولكم مني كل الشكر والاتقدير 

أسعار القطع.rar

[أ / محمد صالح]

الكود جيد ويعمل بسرعة

ربما مع زيادة عدد صفوف البيانات يأتي البطء

أنا شخصيا لا أفضل البحث بمجرد كتابة حرف أو حرفين وهكذا

الأفضل كتابة الكلمة كلها ثم الضغط على زر بحث أو عند الخروج من مربع النص مثلا

حتى تتم عملية البحث مرة واحدة ولا تستهلك قدرا من موارد الجهاز

بالتوفيق

[محمد هشام.]

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

 صراحة لقد جربت الكود الخاص بك يشتغل بشكل جيد لاكن يمكنك تجربة هدا ربما  يكون أسرع 

قم بحدف جميع الأكواد الموجودة داخل اليوزرفورم وضع الأكواد التالية 

Option Compare Text
Dim f, TblPRODUCT, Col(), OneRng
Private Sub UserForm_Initialize()
  Set f = Sheets("PRODUCT")
  TblPRODUCT = f.Range("A2:D" & f.[A65000].End(xlUp).Row).Value
  Col = Array(1, 2, 3, 4)
  OneRng = UBound(Col) + 1
  filtre
  HideBar Me
End Sub

Sub filtre()
  temp1 = "*" & Me.TextBox6 & "*"
  temp2 = "*" & Me.TextBox5 & "*"
  Dim Tbl(): n = 0
  For I = 1 To UBound(TblPRODUCT)
    If TblPRODUCT(I, 1) Like temp1 And TblPRODUCT(I, 2) Like temp2 Then
      n = n + 1: ReDim Preserve Tbl(1 To OneRng, 1 To n)
      c = 0
      For Each k In Col
        c = c + 1: Tbl(c, n) = TblPRODUCT(I, k)
      Next k
    End If
  Next I
  If n > 0 Then
    Me.ListBox1.Column = Tbl
  Else
    Me.ListBox1.Clear
  End If
    Me.TextBox7.Value = n
End Sub

Private Sub TextBox6_Change()
  filtre
End Sub

Private Sub TextBox5_Change()
  filtre
End Sub

Private Sub ListBox1_Click()
  If Me.ListBox1.ListIndex <> -1 Then
    Me.TextBox1.Value = Me.ListBox1.Column(0, Me.ListBox1.ListIndex)
    Me.TextBox2.Value = Me.ListBox1.Column(1, Me.ListBox1.ListIndex)
    Me.TextBox3.Value = Me.ListBox1.Column(2, Me.ListBox1.ListIndex)
    Me.TextBox4.Value = Me.ListBox1.Column(3, Me.ListBox1.ListIndex)
  End If
End Sub

Private Sub UserForm_Activate()
    Me.Label23.Caption = Date
    UpdateTime
End Sub

Private Sub UpdateTime()
    Dim r As Long
    Dim startTime As Double
    startTime = Timer
    Do While Timer < startTime + 1
        Me.Label22.Caption = Format(Now, "h:mm:ss")
        DoEvents
        For r = 1 To 100000: Next r
    Loop
    UpdateTime
End Sub
                                      
Private Sub CommandButton1_Click()
    ThisWorkbook.Save
    Application.Quit
End Sub
                                      
Private Sub CommandButton2_Click()
    Application.Visible = True
    Unload Me
End Sub

وفي Module1  

Option Explicit
#If VBA7 Then
    Public Declare PtrSafe Function FindWindow Lib "user32" _
                Alias "FindWindowA" _
               (ByVal lpClassName As String, _
                ByVal lpWindowName As String) As Long
  
    Public Declare PtrSafe Function GetWindowLong Lib "user32" _
                Alias "GetWindowLongA" _
               (ByVal hWnd As Long, _
                ByVal nIndex As Long) As Long
  
    Public Declare PtrSafe Function SetWindowLong Lib "user32" _
                Alias "SetWindowLongA" _
               (ByVal hWnd As Long, _
                ByVal nIndex As Long, _
                ByVal dwNewLong As Long) As Long
  

    Public Declare PtrSafe Function DrawMenuBar Lib "user32" _
               (ByVal hWnd As Long) As Long
#Else
    Public Declare Function FindWindow Lib "user32" _
                Alias "FindWindowA" _
               (ByVal lpClassName As String, _
                ByVal lpWindowName As String) As Long

    Public Declare Function GetWindowLong Lib "user32" _
                Alias "GetWindowLongA" _
               (ByVal hWnd As Long, _
                ByVal nIndex As Long) As Long

    Public Declare Function SetWindowLong Lib "user32" _
                Alias "SetWindowLongA" _
               (ByVal hWnd As Long, _
                ByVal nIndex As Long, _
                ByVal dwNewLong As Long) As Long
  
    Public Declare Function DrawMenuBar Lib "user32" _
               (ByVal hWnd As Long) As Long
#End If
Sub HideBar(frm As Object)
Dim Style As Long, Menu As Long, hWndForm As Long
hWndForm = FindWindow("ThunderDFrame", frm.Caption)
Style = GetWindowLong(hWndForm, &HFFF0)
Style = Style And Not &HC00000
SetWindowLong hWndForm, &HFFF0, Style
DrawMenuBar hWndForm
End Sub

 

أسعار القطع.xlsm

[Hasan-hasan]

كل الشكر والتقدير لكم أساتذتي الكرام