تصدير بيانات أوراق محددة الى ملف مُغلق

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

Sub Test()

    Const shName1 As String = "ورقة8", shName2 As String = "ورقة9"

    Dim wbResult As Workbook, wb As Workbook, sh1 As Worksheet, sh2 As Worksheet, ws1 As Worksheet, ws2 As Worksheet, myPath As String, myFile As String

    Application.ScreenUpdating = False

        Set wbResult = Workbooks.Open(ThisWorkbook.Path & "النتائج.xlsx")

        With wbResult

            Set sh1 = .Worksheets(shName1)

            Set sh2 = .Worksheets(shName2)

            sh1.Range("A1").CurrentRegion.Offset(1).Clear

            sh2.Range("A1").CurrentRegion.Offset(1).Clear

        End With

        myPath = ThisWorkbook.Path & "المجلد الرئيسى"

        myFile = Dir(myPath & "*.xls*")

        Do While myFile <> ""

            Set wb = Workbooks.Open(myPath & myFile, False)

            Set ws1 = wb.Worksheets(shName1)

            Set ws2 = wb.Worksheets(shName2)

            ws1.Range("A1").CurrentRegion.Offset(1).Copy sh1.Range("A" & sh1.Cells(Rows.Count, 1).End(xlUp).Row + 1)

            ws2.Range("A1").CurrentRegion.Offset(1).Copy sh2.Range("A" & sh2.Cells(Rows.Count, 1).End(xlUp).Row + 1)

            wb.Close SaveChanges:=False

            myFile = Dir

        Loop

        wbResult.Close SaveChanges:=True

    Application.ScreenUpdating = True

    MsgBox "Done...", 64

End Sub