أبو قاسم قام بنشر يونيو 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...
الردود الموصى بها
Join the conversation
You can post now and register later. If you have an account, sign in now to post with your account.