Перебирая книги в папке

Question

Я пытаюсь скопировать определенные ячейки из всех книг в папке. Приведенный ниже код повторяет только первый файл. От новичка ie до VBA. Любая помощь приветствуется

Заранее спасибо

Sub Get_Data()

Dim Directory As String
Dim Filename As String
Dim Sheet As Worksheet
Dim i As Integer
Dim j As Integer
Dim wsDest As Workbook

Application.ScreenUpdating = False

Set wsDest = ThisWorkbook
Directory = "C:\Users\dchandarman\Desktop\Current Season\Weekly Production SA\"
Filename = Dir(Directory & "*.xls")

Do While Filename <> ""
MsgBox Filename
Workbooks.Open (Directory & Filename)
Application.ActiveWorkbook.Worksheets("Exec").Range("C21:Y21").Copy
wsDest.Worksheets("Sheet1").Cells(Rows.Count, "B").End(xlUp).Offset(1).PasteSpecial                         
Paste:=xlPasteValuesAndNumberFormats
Application.ActiveWorkbook.Worksheets("Exec").Range("C23:Y23").Copy
wsDest.Worksheets("Sheet1").Cells(Rows.Count, "B").End(xlUp).Offset(1).PasteSpecial         
Paste:=xlPasteValuesAndNumberFormats
Application.Workbooks(Filename).Worksheets("Exec").Range("C31:Y32").Copy
wsDest.Worksheets("Sheet1").Cells(Rows.Count, "B").End(xlUp).Offset(1).PasteSpecial 
Paste:=xlPasteValuesAndNumberFormats

i = 0

Do Until i = 4
Application.Workbooks(Filename).Worksheets("Exec").Range("D7").Copy
wsDest.Worksheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Offset(1).PasteSpecial             
Paste:=xlPasteValuesAndNumberFormats
i = i + 1
Loop
Application.Workbooks(Filename).Close Savechanges:=False
Loop
End Sub

Answer 1

Вы можете копировать / вставлять несмежные диапазоны.

Sub Get_Data2()

    Const Directory = "C:\Users\dchandarman\Desktop\Current Season\Weekly Production SA\"

    Dim Filename As String
    Dim wsDest As Worksheet, rngDest As Range
    Dim wbSrc As Workbook, wsSrc As Worksheet

    Set wsDest = ThisWorkbook.Sheets("Sheet1")

    Filename = Dir(Directory & "*.xls")

    Do While Filename <> ""
        MsgBox Filename
        Set wbSrc = Workbooks.Open(Directory & Filename)
        Set wsSrc = wbSrc.Worksheets("Exec")
        wsSrc.Range("C21:Y21,C23:Y23,C31:Y32").Copy

        Set rngDest = wsDest.Cells(Rows.Count, "B").End(xlUp).Offset(1)
        rngDest.PasteSpecial Paste:=xlPasteValuesAndNumberFormats

        wsSrc.Range("D7").Copy
        rngDest.Offset(0, -1).Resize(4, 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
        wbSrc.Close

        Filename = Dir
    Loop

    MsgBox "Done"

End Sub