循环浏览目录中的excel文件并复制到主表上

Question

I have a folder with nearly 1000 .csv files. Each of these files contains 2 columns, and I would like to copy only one of these columns and transpose it onto a new workbook. The new workbook will contain all the data from each of these files. The following code is what I have generated:

    Sub AllFiles()
    Application.EnableCancelKey = xlDisabled

    Dim folderPath As String
    Dim Filename As String
    Dim wb As Workbook

    folderPath = "J:etc. etc. etc." 'contains folder path

    If Right(folderPath, 1) <> "\" Then folderPath = folderPath + "\"

    Filename = Dir(folderPath & "*.csv")
    Do While Filename <> ""
      Application.ScreenUpdating = False
        Set wb = Workbooks.Open(folderPath & Filename)

        wb.Range(Range("B1"), Range("B1").End(xlDown)).Select
        Application.CutCopyMode = False
        Selection.Copy
        ActiveWorkbook.Close True
        Windows("Compiled.xlsm").Activate
        Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Transpose:=True

        Filename = Dir
    Loop
  Application.ScreenUpdating = True
End Sub

For whatever reason the code does not work and a box pops-up saying "Code execution has been interrupted." Once I hit "Debug" the following line is highlighted:

wb.Range(Range("B1"), Range("B1").End(xlDown)).Select

I am not experienced with VBA at all and I am having trouble troubleshooting this issue. Any idea on what this means and what I can do?

Answer 1

The highlighted line is referring to a range on the workbook that is running the macro as opposed to the range within the workbook you have opened. Try replacing with this:

wb.Range(wb.Range("B1"), wb.Range("B1").End(xlDown)).Select

However I would suggest you avoid using the Select function altogether as it tends to slow down code. I've trimmed the loop a bit to avoid using Select and Activate :

Do While Filename <> ""
  Application.ScreenUpdating = False
    Set wb = Workbooks.Open(folderPath & Filename)
    wb.Range(wb.Cells(1,"B"), wb.Cells(Rows.Count,"B").End(xlUp)).Copy
    Workbooks("Compiled.xlsm").Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Transpose:=True
    wb.Close True
    Filename = Dir
Loop

Answer 2

Once you open file file, the active workbook is the book just opened and the active sheet is also established.

Your code fails primarily because of the wb. . (In general you would use a sheet reference instead) , but in this case, replace:

wb.Range(Range("B1"), Range("B1").End(xlDown)).Select

with:

Range("B1").End(xlDown)).Select

(You also do not need Select to accomplish a copy/paste)

Answer 3

try with below

Sub AllFiles()
    Application.EnableCancelKey = xlDisabled
    Dim folderPath As String
    Dim Filename As String
    Dim wb As Workbook
    folderPath = "c:\work\test\" 'contains folder path
    If Right(folderPath, 1) <> "\" Then folderPath = folderPath + "\"
    Filename = Dir(folderPath & "*.xlsx")
    Do While Filename <> ""
        Application.ScreenUpdating = False
        Set wb = Workbooks.Open(folderPath & Filename)
        Range("B1:B" & Range("B" & Rows.count).End(xlUp).Row).Copy
        Workbooks("Compiled").Worksheets("Sheet1").Range("A" & Range("A" & Rows.count).End(xlUp).Row + 1).PasteSpecial Transpose:=True
        Workbooks(Filename).Close True
        Filename = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

Answer 4

wb.Range(...) will never work since wb is a Workbook object. You need a Worksheet object. Try:

Dim ws As Worksheet
Set ws = wb.Activesheet
ws.Range(ws.Range("B1"), ws.Range("B1").End(xlDown)).Select