أبو قاسم قام بنشر يونيو 2 مشاركة قام بنشر يونيو 2 (معدل) السلام عليكم مشكورين على جهودكم الطيبة محتاج إضافة على الملف المرفق إضافة بحث وإظهار النتائج يوزر فورم١.xlsb تم تعديل يونيو 2 بواسطه أبو قاسم ارفاق رابط هذا التعليق شارك More sharing options...
أفضل إجابة محمد هشام. قام بنشر يونيو 2 أفضل إجابة مشاركة قام بنشر يونيو 2 (معدل) وعليكم السلام ورحمة الله تعالى وبركاته Option Compare Text Dim depart, Cnt, comment, f, ColSearch(), J Public Property Get WS() As Worksheet: Set WS = ActiveSheet End Property Private Sub UserForm_Initialize() Dim arr() comment = " تحديد ورقة العمل" Me.Label1.Width = 900 depart = Me.Label1.Left Message = " برنامج المخازن يرحب بكم . صل على محمد" Me.Label1.Caption = "**********" & Message & "**********" & Message & "************" Cnt = Len(Me.Label1.Caption): Me.ComboBox1 = comment ColSearch = Array(3, 2, 1) J = UBound(ColSearch) + 1 For i = 1 To 3: Me("head" & i).Visible = False: Next i k = 1 For Each sh In ActiveWorkbook.Sheets If sh.Cells(3, 3) <> Empty Then ReDim Preserve arr(1 To k) arr(k) = sh.Name k = k + 1 End If Next sh Me.ComboBox1.List = arr Me.ComboBox1.ListIndex = 0 Count.Caption = ListBox1.ListCount Me.ComboBox1 = comment End Sub '*************************************** Private Sub Textbox1_Change() r = "*" & Me.Textbox1 & "*" Dim Cpt(): n = 0 For i = 1 To UBound(f) If f(i, 1) Like r Then ' فلترة بالاسم عمود (1) n = n + 1: ReDim Preserve Cpt(1 To J, 1 To n) c = 0 For Each k In ColSearch c = c + 1: Cpt(c, n) = f(i, k) Next k End If Next i If n > 0 Then Me.ListBox1.Column = Cpt Else Me.ListBox1.Clear Count.Caption = ListBox1.ListCount End Sub '******************************* Private Sub ComboBox1_Change() On Error Resume Next Sheets(CStr(ComboBox1)).Activate f = WS.Range("A3:C" & WS.[a65000].End(xlUp).Row).Value If Me.ComboBox1 <> comment And WS.Cells(3, 3) <> "" Then For i = 1 To 3: Me("Hard" & i).Visible = True: Next i Set d = CreateObject("Scripting.Dictionary") For i = LBound(f) To UBound(f) If f(i, 1) <> "" Then d(i) = Array(f(i, 3), f(i, 2), f(i, 1)) Next i n = d.Count If n > 0 Then Dim Cpt: Cpt = Application.Transpose(d.items) ReDim Preserve Cpt(1 To 3, 1 To n + 1) Me.ListBox1.List = Application.Transpose(Cpt) Me.ListBox1.RemoveItem n For i = 1 To 3: Me("Hard" & i) = WS.Cells(2, i): Next i Count.Caption = ListBox1.ListCount End If End If End Sub يوزر فورم3.xlsb تم تعديل يونيو 3 بواسطه محمد هشام. 3 رابط هذا التعليق شارك More sharing options...
أبو قاسم قام بنشر يونيو 3 الكاتب مشاركة قام بنشر يونيو 3 جزاك الله خير المطلوب وزيادة شكرا لك 1 رابط هذا التعليق شارك More sharing options...
محمد هشام. قام بنشر يونيو 3 مشاركة قام بنشر يونيو 3 ولك بالمثل اخي @أبو قاسم يسعدنا اننا استطعنا مساعدتك 2 1 رابط هذا التعليق شارك More sharing options...
الردود الموصى بها
من فضلك سجل دخول لتتمكن من التعليق
ستتمكن من اضافه تعليقات بعد التسجيل
سجل دخولك الان