Question

我正在尝试从文件夹中的所有工作簿中复制某些单元格。下面的代码仅使循环遍历第一个文件。 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

循环浏览文件夹中的工作簿

1 个答案: