بسم الله الرحمن الرحيم

اليوم نقدم لكم مثال طلبه الكثير من الاعضاء
وهو كيفية عرض بيانات او ترحيل بيانات من ملف مغلق لملف مفتوح
المثال المرفق عبارة عن ملفين Data.xlsm و Search.xlsm
ملف داتا وملف بحث
نقوم بفتح ملف البحث ونبحث عن اي بيان موجود في الملف داتا وجلبه الى ملف البحث
ويمكن ترحيل البيان الموجود في الملف البحث الى ملف الداتا
الكود الخاص بالبحث واستدعاء البيانات من الملف داتا الى ملف البحث

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

الملفات مرفقة
بحث وترحيل لملف مغلق.zip

تحياتي
ياسر العربي