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

أقدم لكم كود يقوم بجلب واستدعاء بيانات من جميع أوراق العمل في مصنف مغلق.

بفرض أن لديك مجموعة مصنفات مغلقة وتمت تسميتها بالسنوات أي مصنف باسم 2013 ومصنف باسم 2014 وهكذا ..

وفي كل مصنف من هذه المصنفات يوجد عدد 12 ورقة عمل بشهور السنة (يناير - فبراير - مارس - وهكذا ...)
وفي كل ورقة عمل يوجد خلايا محددة تريد جلبها للمصنف الحالي في ورقة العمل Sheet1


والمطلوب جلب بيانات هذه الخلايا الثلاثة الموجودة في كل ورقة عمل في المصنف المغلق إلى ورقة العمل Sheet1 بهذا الشكل


وذلك بالاعتماد على قيمة الخلية B3 التي تحتوي على اسم المصنف المغلق المراد جلب البيانات منه

كل ما عليك فعله هو أن تقوم بكتابة أو ختيار اسم المصنف من الخلية B3 ثم النقر على زر الأمر RUN (مع العلم أنه يمكن تفعيل الكود بمجرد التغير في قيمة الخلية) ، فيقوم الكود بفحص مسار المصنف للتأكد من وجود المصنف من عدمه ، فإذا لم يكن المصنف موجود يتم إظهار رسالة تفيد بذلك ، أما إذا كان المصنف موجود فيتم فتح المصنف المغلق ويتم عمل حلقة تكرارية لكل أوراق العمل لتخزين قيم الخلايا المطلوب استدعائها ثم يغلق المصنف وأخيراً توضع قيم المصفوفة في النطاق B6:M8

إليكم الكود المستخدم لتنفيذ المهمة ، ويوضع الكود في موديول عادي

Sub Grab_Data_From_Closed_Workbook()
    Dim strFileName     As String
    Dim arr             As Variant
    Dim temp            As Variant
    Dim sh              As Worksheet
    Dim counter         As Integer
    Dim i               As Integer

    strFileName = ThisWorkbook.Path & "" & Sheet1.Range("B3").Value & ".xls"

    Application.ScreenUpdating = False
        Sheets("Sheet1").Range("B6:M8").ClearContents
        
        If Len(Dir(strFileName)) > 0 Then
            Workbooks.OpenText Filename:=strFileName
    
            ReDim temp(1 To 12, 1 To 3)
    
            For Each sh In ActiveWorkbook.Worksheets
                With sh
                    counter = counter + 1
                    arr = Array(.Range("C6").Value, .Range("E6").Value, .Range("G6").Value)
                    i = i + 1
                    For counter = 1 To 3
                        temp(i, counter) = arr(counter - 1)
                    Next counter
                End With
            Next sh
            
            ActiveWorkbook.Close False
            
            Sheets("Sheet1").Range("B6").Resize(UBound(temp, 2), UBound(temp, 1)).Value = Application.Transpose(temp)
        Else
            MsgBox strFileName & " Can't Be Found!", vbExclamation, "File Not Found"
        End If
    Application.ScreenUpdating = True
End Sub

رابط الملف من هنا

إعداد وتقديم / ياسر خليل أبو البراء