السلام عليكم
أخي الكريم
غير كود الإستدعاء للتالي
Private Sub ListBox1_Click()
Sheet1.[C5,C7,C9,A37,H14:H34,A14:E34].ClearContents
[C3] = ListBox1.Value
Me.Hide
On Error Resume Next
With Sheet2
LR = .[J10000].End(xlUp).Row
r1 = WorksheetFunction.Match([C3], .[B1:B10000], 0)
r2 = r1
For i = 1 To 20
If IsEmpty(.Cells(r1 + i, 2)) Then
r2 = r1 + i
Else
GoTo 10
End If
If r2 >= LR Then GoTo 10
Next i
10
Set rg1 = .Range("F" & r1 & ":H" & r2)
Set rg2 = .Range("J" & r1 & ":J" & r2)
End With
rg1.Copy
Sheet1.[C14].PasteSpecial Paste:=xlPasteValues
rg2.Copy
Sheet1.[H14].PasteSpecial Paste:=xlPasteValues
Sheet1.[C5] = Sheet2.Cells(r1, "C")
Sheet1.[C7] = Sheet2.Cells(r1, "D")
Sheet1.[C9] = Sheet2.Cells(r1, "E")
Sheet1.[A37] = Sheet2.Cells(r1, "I")
Sheet1.Activate
[C3].Select
Application.CutCopyMode = False
End Sub