كود ربط اليست بوكس مع خلايا اكسيل

Private Sub TextBox1_Change()
 Dim w As Worksheet
 Dim col As New Collection
 Dim v As Variant
 Dim b() As Variant
 Dim a(1 To 7) As Variant
 Dim r As Long
 Dim m As Long
 Dim k As Long
 Dim c As Long

 Me.ListBox1.Clear
 If Me.TextBox1.Value = "" Then Exit Sub

 Set w = ThisWorkbook.Worksheets(1)
 m = w.Range("B" & w.Rows.Count).End(xlUp).Row
 On Error Resume Next
 For r = 2 To m
 If InStr(1, w.Range("B" & r).Value, Me.TextBox1.Value, vbTextCompare) > 0 Then
 col.Add UCase(w.Range("B" & r).Value), UCase(w.Range("B" & r).Value)
 End If
 Next r
 On Error GoTo 0

 For Each v In col
 r = Application.Match(v, w.Range("B1:B" & m), 0)
 For c = 1 To 4
 a(c) = w.Cells(r, c).Value
 Next c
 For c = 5 To 7
 a(c) = Application.SumIf(w.Range("B1:B" & m), v, w.Range(w.Cells(1, c), w.Cells(m, c)))
 Next c
 k = k + 1
 ReDim Preserve b(1 To k)
 b(k) = a
 Next v

 On Error Resume Next
 If UBound(b) > 0 Then
 If UBound(b) = 1 Then
 Me.ListBox1.Column = Application.Index(b, 0, 0)
 Else
 Me.ListBox1.List = Application.Index(b, 0, 0)
 End If
 End If
 On Error GoTo 0
End Sub

Private Sub ListBox1_Click()
 Dim i As Long

 For i = 0 To ListBox1.ListCount - 1
 If ListBox1.Selected(i) Then TextBox2.Value = ListBox1.List(i, 6)
 Next i
End Sub