如何打开多个工作簿以从中复制数据 [英] How to open multiple workbooks to copy the data from

问题描述

我用vba编写了一个脚本，该脚本能够从桌面上的特定文件夹导入.xlsx文件，然后从那里复制数据，以便将其粘贴到当前活动的工作表中.我的脚本对于单个.xlsx文件运行良好.

I've written a script in vba which is able to import a .xlsx file from a specific folder in my desktop and copy the data from there in order to paste the same in my currently active worksheet. My script is doing fine for a single .xlsx file.

该文件夹包含100个.xlsx文件. Sheet1中的每个文件都具有固定的库仑数据(行可能会有所不同).

The folder contains 100's of .xlsx files. Each of the files in their Sheet1 having data with fixed coulmns (rows may vary).

我现在要做的是在活动工作表(appended one after another in row-wise) 中一一获取这些文件中的所有数据.

What I wish to do now is get all the data from those files one by one in my active worksheet (appended one after another in row-wise).

到目前为止，我的尝试:

My attempt so far:

Sub OpenAndImportFile()
    Dim wbO As Workbook, wsI As Worksheet, cel As Range

    Set wsI = ThisWorkbook.Worksheets("Sheet1")

    Set wbO = Workbooks.Open("C:\Users\WCS\Desktop\files\coworking\list_members-coworking-annkingman-2018-12-31-14-55-07-eisaiah_e.xlsx")

    For Each cel In wbO.Sheets(1).Range("A1:A" & wbO.Sheets(1).Cells(Rows.count, 1).End(xlUp).row)
        cel(1, 1).EntireRow.Copy wsI.Range(cel(1, 1).Address)
    Next cel

    wbO.Close SaveChanges:=False
End Sub

推荐答案

使用VBA(而不是Power Query之类的东西)并假设您要复制第一张工作表(打开的工作簿)中的数据，然后粘贴到<Thisworkbook中的c5>，代码可能类似于以下内容.

Using VBA (instead of something like Power Query) and assuming you want to copy the data from the first sheet (of the workbook you open) and paste to "Sheet1" in Thisworkbook, the code might look something like the below.

在运行下面的代码之前，最好制作整个文件夹(包含.xlsx文件)的副本(不必要，但以防万一).

Might be good to make a copy of the entire folder (containing .xlsx files) before running the code below (unnecessary, but just in case).

如果要打开数百个文件，则可能需要在For循环之前和之后切换Application.ScreenUpdating(以防止不必要的屏幕闪烁和重画).

If you have hundreds of files to open, you might want to toggle Application.ScreenUpdating before and after the For loop (to prevent unnecessary screen flickering and redrawing).

Option Explicit

Private Sub CopyPasteSheets()
    Dim folderPath As String
    folderPath = "C:\Users\WCS\Desktop\files\coworking\"

    If Len(VBA.FileSystem.Dir$(folderPath, vbDirectory)) = 0 Then
        MsgBox ("'" & folderPath & "' does not appear to be a valid directory." & vbNewLine & vbNewLine & "Code will stop running now.")
        Exit Sub
    End If

    Dim filePathsFound As Collection
    Set filePathsFound = New Collection

    Dim Filename As String
    Filename = VBA.FileSystem.Dir$(folderPath & "*.xlsx", vbNormal)

    Do Until Len(Filename) = 0
        filePathsFound.Add folderPath & Filename, Filename
        Filename = VBA.FileSystem.Dir$()
    Loop

    Dim filePath As Variant ' Used to iterate over collection
    Dim sourceBook As Workbook

    Dim destinationSheet As Worksheet
    Set destinationSheet = ThisWorkbook.Worksheets("Sheet1") ' Change to whatever yours is called
    'destinationSheet.Cells.Clear ' Uncomment this line if you want to clear before beginning

    Dim rowToPasteTo As Long
    rowToPasteTo = destinationSheet.Cells(destinationSheet.Rows.Count, "A").End(xlUp).Row
    If rowToPasteTo > 1 Then rowToPasteTo = rowToPasteTo + 1

    For Each filePath In filePathsFound
        On Error Resume Next
        Set sourceBook = Application.Workbooks.Open(Filename:=filePath, ReadOnly:=True)
        On Error GoTo 0

        If Not (sourceBook Is Nothing) Then
            With sourceBook.Worksheets(1) ' Might be better if you refer to sheet by name rather than index
                Dim lastRowToCopy As Long
                lastRowToCopy = .Cells(.Rows.Count, "A").End(xlUp).Row

                With .Range("A1:A" & lastRowToCopy).EntireRow
                    If (rowToPasteTo + .Rows.Count - 1) > destinationSheet.Rows.Count Then
                        MsgBox ("Did not paste rows from '" & sourceBook.FullName & "' due to lack of rows on sheet." & vbNewLine & vbNewLine & "Code will close that particular workbook and then stop running.")
                        sourceBook.Close
                        Exit Sub
                    End If

                    .Copy destinationSheet.Cells(rowToPasteTo, "A").Resize(.Rows.Count, 1).EntireRow
                    rowToPasteTo = rowToPasteTo + .Rows.Count
                End With
            End With
            sourceBook.Close
            Set sourceBook = Nothing
        Else
            MsgBox ("Could not open file at '" & CStr(sourceBook) & "'. Will try to open remaining workbooks.")
        End If
    Next filePath
End Sub

这篇关于如何打开多个工作簿以从中复制数据的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！