السلام عليكم مطلوب الليست بوكس تظهر عمودين بدل عمود واحد وشكرا

[AMIRBM]

السلام عليكم ورحمة الله مطلوب الليست بوكس في فورم البحث تظهر عمودين بدل عمود واحد وشكرا

المرحليات أوفيسنا.xlsm

[عبدالله بشير عبدالله]

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

لم توضح ارتباط العمود الثاتي بأيعم ود في الشيت 

اليك التعديل 

Private Sub TextBox1_Change()
    ListBox1.Clear
    Application.ScreenUpdating = False
    
    Dim ws As Worksheet: Set ws = Sheets("add")
    Dim lr As Long, c As Range, b As Integer, k As Long
    Dim arrData() As Variant
    Dim i As Long, j As Long
    
    lr = 0
    For Each c In ws.Range("b5:b" & ws.Cells(ws.Rows.Count, "B").End(xlUp).Row)
        b = InStr(1, c.Value, TextBox1.Value, vbTextCompare)
        If b > 0 Then
            lr = lr + 1
            ReDim Preserve arrData(1 To 2, 1 To lr)
            arrData(1, lr) = c.Value
            arrData(2, lr) = c.Offset(0, 4).Value
        End If
    Next c
    
    With ListBox1
        .ColumnCount = 2
        .ColumnWidths = "100;100"
        If lr > 0 Then
            .List = Application.Transpose(arrData)
        End If
    End With
    
    Application.ScreenUpdating = True
End Sub

في الكود السابق تم ربط العمود الثاني باسم المعلم يمكنك التعديل يالتغيير في رقم 4 فهي تشير الى رقم العمود في الشيت بعد عمود الاسم

            arrData(2, lr) = c.Offset(0, 4).Value

كنا يمكنك من تعديل عرض العمود  بالتعديل في رقمي 100 الاول للعمود الاول والثانية للعمود الثاني
        .ColumnWidths = "100;100"
ارجو   ما قدمته ان يكون طلبك

كل عام وانت بخير 

المرحليات أوفيسنا.xlsm

[محمد هشام.]

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

اخي @AMIRBM تم تعديل الكود حسب طلبك ليعرض عمودين في ListBox داخل نموذج البحث  مثلا  (الإسم + التسلسل)  يمكنك تعديله بما يناسبك 
وقد قمت  بمحاولة تنقيحه وتحسينه ليكون أكثر كفاءة وتنظيما

يرجى أولا تفريغ جميع الأكواد السابقة من النموذج ثم نسخ الكود التالي بالكامل

Option Explicit
Private ColArr As Variant
Public Property Get WS() As Worksheet: Set WS = Sheets("add"): End Property
Public Property Get dest() As Worksheet: Set dest = Sheets("search"): End Property

Private Sub UserForm_Initialize()
    TextBox1.SetFocus
    'قم بتحديد الأعمدة المرغوب عرضها
    ColArr = Array(2, 1)  ' 2 = الإسم /  1 = التسلسل
    With ListBox1: .ColumnCount = UBound(ColArr) + 1: .ColumnWidths = "100pt;40pt": End With
End Sub
Private Sub TextBox1_Change()
    Dim c As Range, tmp As String, lastRow As Long, i As Long, listCount As Long
    ListBox1.Clear
    If IsEmpty(ColArr) Then Exit Sub
    tmp = Trim(TextBox1.Value)
    If Len(tmp) = 0 Then Exit Sub
    SetApp False
    lastRow = WS.Cells(WS.Rows.Count, ColArr(0)).End(xlUp).Row
    For Each c In WS.Range(WS.Cells(5, ColArr(0)), WS.Cells(lastRow, ColArr(0)))
        If InStr(1, c.Value, tmp, vbTextCompare) > 0 Then
            ListBox1.AddItem c.Value
            listCount = ListBox1.listCount
            For i = 1 To UBound(ColArr)
                ListBox1.List(listCount - 1, i) = c.EntireRow.Cells(1, ColArr(i)).Value
            Next i
        End If
    Next c
    SetApp True
End Sub
Private Sub CommandButton1_Click()
    Dim Irow As Long, f As Long, i As Long, xName As String, cnt As Boolean: cnt = False
    If ListBox1.listCount = 0 Then MsgBox "لا توجد نتائج للبحث", vbExclamation, "تنبيه": Exit Sub
    xName = Trim(TextBox1.Value): Irow = WS.Cells(WS.Rows.Count, ColArr(0)).End(xlUp).Row
    SetApp False
    For i = 5 To Irow
        If WS.Cells(i, ColArr(0)).Value = xName Then
            If Not cnt Then dest.Range("A8:L" & dest.Rows.Count).ClearContents
            f = dest.Cells(dest.Rows.Count, "A").End(xlUp).Row + 1
            dest.Range("A" & f).Resize(1, 12).Value = WS.Cells(i, 2).Resize(1, 12).Value
            cnt = True
        End If
    Next i
    If Not cnt Then MsgBox "لم يتم العثور على الاسم" & xName & " ضمن كشف المرحليات", vbInformation, "نتيجة البحث"
   SetApp True: Unload Me
End Sub
Private Sub ListBox1_Click()
    TextBox1.Value = ListBox1.List(ListBox1.ListIndex, 0)
End Sub
Private Sub SetApp(ByVal enable As Boolean)
    On Error Resume Next
    With Application
        .ScreenUpdating = enable: .EnableEvents = enable: .DisplayAlerts = enable
        .Calculation = IIf(enable, xlCalculationAutomatic, xlCalculationManual)
    End With
    On Error GoTo 0
End Sub

 

المرحليات أوفيسنا v2.xlsm

[AMIRBM]

 

شكرا بارك الله فيك أستاذ وعيدكم مبارك مسبقا

[AMIRBM]

شكرا بارك الله فيك أستاذ