Как открыть несколько рабочих книг для копирования данных из

Question

Я написал скрипт в vba, который может импортировать файл .xlsx из определенной папки на моем рабочем столе и копировать данные оттуда, чтобы вставить его в мою текущую активную рабочую таблицу.Мой сценарий работает нормально для одного .xlsx файла.

Папка содержит 100 файлов .xlsx.Каждый из файлов в Sheet1 содержит данные с фиксированными именами (строки могут отличаться).

Теперь я хочу получить все данные из этих файлов один за другим вмоя активная рабочая таблица (appended one after another in row-wise) .

Моя попытка на данный момент:

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

Answer 1

Открыть и импортировать файл

Код

Sub OpenAndImportFile()

    ' Source File Folder Path
    Const cStrFolder As String = "C:\Users\WCS\Desktop\files\coworking"
    Const cStrExt As String = "*.xls*"         ' Source File Pattern
    Const cVntSrcName As Variant = 1           ' Source Worksheet Name/Index
    Const cVntSource As Variant = "A"          ' Source Column Letter/Number

    Const cVntTgtName As Variant = "Sheet1"    ' Target Worksheet Name/Index
    Const cVntTarget As Variant = "A"          ' Target Column Letter/Number

    Dim objWbSource As Workbook   ' Source Workbook
    Dim objRngU As Range          ' Source Union Range
    Dim StrFile As String         ' Source File Name
    Dim i As Long                 ' Source Row Counter
    Dim j As Long                 ' Target Row Counter

    Dim objWsTarget As Worksheet  ' Target Worksheet
    Dim cLngPasteRow As Long      ' Target Paste Row

    Set objWsTarget = ThisWorkbook.Worksheets(cVntTgtName)
    objWsTarget.Cells.Clear

    cLngPasteRow = 1

    StrFile = Dir(cStrFolder & "\" & cStrExt)

    On Error GoTo ProcedureExit

    With Application
      .ScreenUpdating = False
      .Calculation = xlCalculationManual
      .DisplayAlerts = False
    End With

    Do While Len(StrFile) > 0

        Set objWbSource = Workbooks.Open(cStrFolder & "\" & StrFile)

        With objWbSource.Worksheets(1)

'            Debug.Print objWbSource.Name & "  " & .Name & "   " & cLngPasteRow

            If .Cells(.Rows.Count, cVntSource).End(xlUp).Row = 1 _
                And .Cells(1, 1) = "" Then
              Else
                For i = 1 To .Cells(.Rows.Count, cVntSource).End(xlUp).Row
                    If Not objRngU Is Nothing Then
                        Set objRngU = Union(objRngU, .Cells(i, cVntSource))
                      Else
                        Set objRngU = .Cells(i, cVntSource)
                    End If
                    j = j + 1
                Next
            End If
        End With

        If Not objRngU Is Nothing Then
            objRngU.EntireRow.Copy objWsTarget.Cells(cLngPasteRow, cVntTarget)
            Set objRngU = Nothing
            cLngPasteRow = j + 1 ' Next row to copy data to.
        End If

        objWbSource.Close False

        StrFile = Dir

    Loop

ProcedureExit:

    Set objRngU = Nothing
    Set objWbSource = Nothing
    Set objWsTarget = Nothing

    With Application
      .ScreenUpdating = True
      .Calculation = xlCalculationAutomatic
      .DisplayAlerts = True
    End With


End Sub

Answer 2

Вот как я поступил ради достижения цели:

Sub OpenAndImportFile()
    Dim wbO As Workbook, wsI As Worksheet, cel As Range
    Dim daddr$, Filename$, foundfiles As New Collection
    Dim xlfile As Variant

    Application.ScreenUpdating = False

    daddr = Environ("USERPROFILE") & "\Desktop\files\coworking\"
    Filename = Dir(daddr & "*.xlsx")
    Set wsI = ThisWorkbook.Worksheets("Sheet1")

    Do While Len(Filename) > 0
        foundfiles.Add Filename
        Filename = Dir
    Loop

    For Each xlfile In foundfiles
        Set wbO = Workbooks.Open(daddr & xlfile)

        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("A" & Rows.count).End(xlUp).Offset(1, 0)
        Next cel
        wbO.Close SaveChanges:=False
    Next xlfile

    Application.ScreenUpdating = True
End Sub

Answer 3

Используя VBA (вместо чего-то вроде Power Query) и предполагая, что вы хотите скопировать данные с первого листа (открытой книги) и вставить в "Sheet1" в Thisworkbook, код может выглядеть примерно так:ниже.

Может быть хорошо сделать копию всей папки (содержащей .xlsx файлов) перед запуском приведенного ниже кода (ненужного, но на всякий случай).

Если у вас есть сотнифайлов, которые нужно открыть, вы можете переключить Application.ScreenUpdating до и после цикла For (чтобы предотвратить ненужное мерцание и перерисовку экрана).

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