Sub Yasser()
Dim serch As Worksheet
Dim wkb As Workbook
Dim lr As Long, x, n, z
Dim targt As String
Dim myArray As Variant
Set serch = Sheets("Sheet1")
Application.ScreenUpdating = 0
serch.Range("A7:M1000").ClearContents
Set wkb = Workbooks.Open(ThisWorkbook.Path & "Data.xlsm")
lr = wkb.Sheets("sheet1").Cells(Rows.Count, 1).End(xlUp).Row
myArray = wkb.Sheets("sheet1").Range("A7:M" & lr)
ReDim y(1 To UBound(myArray, 1), 1 To UBound(myArray, 2))
With serch
srchNum = .Application.WorksheetFunction.Match(.Range("E1"), .Range("A1:C1"), 0)
targt = .Cells(2, srchNum)
If targt = "" Then Exit Sub
For z = LBound(myArray) To UBound(myArray)
If targt Like myArray(z, srchNum) Then
x = x + 1
For n = 1 To 13
y(x, n) = myArray(z, n)
Next
End If
Next
If x > 0 Then .Cells(7, 1).Resize(x, 13).Value = y()
End With
wkb.Close SaveChanges:=True
Application.ScreenUpdating = 1
End Sub
كل ما علينا هو اختيار شرط البحث من الخلية E1 وكتابته في المربع المحدد له والضغط على استدعاء
Sub Yasser2()
Dim wkb As Workbook
Dim myArr As Variant
Dim lr As Long
Application.ScreenUpdating = 0
lr = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
myArr = Sheets("Sheet1").Range("A7:M" & lr)
Set wkb = Workbooks.Open(ThisWorkbook.Path & "Data.xlsm")
wkb.Sheets("sheet1").Cells(Rows.Count, 1).End(xlUp)(2, 1).Resize(UBound(myArr, 1), UBound(myArr, 2)).Value = myArr
wkb.Close SaveChanges:=True
Application.ScreenUpdating = 1
End Sub