Получить данные с нескольких листов в выбранной книге

Question

Я новичок в макросах в Excel, и мне нужно сделать макрос, который получает данные из нескольких листов в выбранной книге.

Пока у меня есть этот код для выбора файла и получения данных из листа 1, но я хочу, чтобы он мог получать информацию со всех листов в выбранном файле.

Sub MergeSelectedWorkbooks()
    Dim SummarySheet As Worksheet
    Dim FolderPath As String
    Dim SelectedFiles() As Variant
    Dim NRow As Long
    Dim FileName As String
    Dim NFile As Long
    Dim WorkBk As Workbook
    Dim SourceRange As Range
    Dim DestRange As Range

    ' Create a new workbook and set a variable to the first sheet.
    Set SummarySheet = Workbooks.Add(xlWBATWorksheet).Worksheets(1)

    ' Modify this folder path to point to the files you want to use.
    FolderPath = "C:\Users\My\Desktop\Path"

    ' Set the current directory to the the folder path.
    ChDrive FolderPath
    ChDir FolderPath

    ' Open the file dialog box and filter on Excel files, allowing multiple files
    ' to be selected.
    SelectedFiles = Application.GetOpenFilename( _
        filefilter:="Excel Files (*.xl*), *.xl*", MultiSelect:=True)

    ' NRow keeps track of where to insert new rows in the destination workbook.
    NRow = 1

    ' Loop through the list of returned file names
    For NFile = LBound(SelectedFiles) To UBound(SelectedFiles)
        ' Set FileName to be the current workbook file name to open.
        FileName = SelectedFiles(NFile)

        ' Open the current workbook.
        Set WorkBk = Workbooks.Open(FileName)


        ' Set the source range to be A9 through C9.
        ' Modify this range for your workbooks. It can span multiple rows.
        Set SourceRange = WorkBk.Worksheets(1).Range("A1:G5")

        ' Set the destination range to start at column B and be the same size as the source range.
        Set DestRange = SummarySheet.Range("A" & NRow)
        Set DestRange = DestRange.Resize(SourceRange.Rows.Count, _
           SourceRange.Columns.Count)

        ' Copy over the values from the source to the destination.
        DestRange.Value = SourceRange.Value

        ' Increase NRow so that we know where to copy data next.
        NRow = NRow + DestRange.Rows.Count

        ' Close the source workbook without saving changes.
        WorkBk.Close savechanges:=False
    Next NFile

    ' Call AutoFit on the destination sheet so that all data is readable.
    SummarySheet.Columns.AutoFit
End Sub

Answer 1

Чтобы сделать это с помощью Excel Automation, сначала определите следующую функцию, которая получает последнюю использованную ячейку на листе, используя описанную здесь методику:

Function LastUsedCell(wks As Excel.Worksheet) As Excel.Range
With wks
    If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
        Set LastUsedCell = .Cells.Find(What:="*", _
            After:=.Range("A1"), _
            Lookat:=xlPart, _
            LookIn:=xlFormulas, _
            SearchOrder:=xlByRows, _
            SearchDirection:=xlPrevious, _
            MatchCase:=False)
    End If
End With
End Function

и эта вспомогательная функция, чтобы определить, с чего начать копирование данных с каждого рабочего листа:

Function GetNextRowStart(wks As Excel.Worksheet) As Excel.Range
Dim lastCell As Excel.Range
Dim nextRow As Integer
nextRow = 1
Set lastCell = LastUsedCell(wks)
If Not lastCell Is Nothing Then nextRow = lastCell.Row + 1
Set GetNextRowStart = wks.Cells(nextRow, 1)
End Function

Тогда вы можете использовать следующий код:

Dim outputWorkbook As Excel.Workbook
Dim outputWorksheet As Excel.Worksheet
Dim filepath As Variant

Set outputWorkbook = Workbooks.Open("D:\Zev\Clients\stackru\outputMultipleWokrbooksWithADO\output.xlsx")
Set outputWorksheet = outputWorkbook.Sheets("Sheet1")

For Each filepath In Application.GetOpenFilename(FileFilter:="Excel Files (*.xl*), *.xl*", MultiSelect:=True)
    Dim wkbk As Excel.Workbook
    Dim wks As Excel.Worksheet
    Set wkbk = Workbooks.Open(filepath, , True)
    For Each wks In wkbk.Sheets
        Dim sourceRange As Excel.Range
        Dim outputRange As Excel.Range
        With wks
            Set sourceRange = .Range(.Cells(1, 1), LastUsedCell(wks))
        End With
        Set outputRange = GetNextRowStart(outputWorksheet)
        sourceRange.Copy outputRange
    Next
Next

outputWorksheet.Columns.AutoFit

---

Предыдущий подход использует Excel Automation - откройте рабочую книгу, возьмите лист, управляйте диапазонами на исходном и выходном листах.

Вы также можете использовать ADODB для чтения листов Excel, как если бы рабочая книга была базой данных, а рабочие листы были ее таблицами; а затем выдать INSERT INTO оператор для копирования исходных записей в выходную рабочую книгу. Он предлагает следующие преимущества:

• Как правило, передача данных с помощью SQL выполняется быстрее, чем передача данных с помощью автоматизации (открытие рабочей книги, копирование и вставка диапазона).
  • Если нет преобразования данных, другой вариант - прочитать Value свойство Range объект, который возвращает двумерный массив. Это может быть легко назначено / вставлено во все, что ожидает такой массив, включая Value собственность
• Преобразование данных с помощью SQL является декларативным - просто определите новую форму данных. Напротив, преобразование данных с помощью автоматизации подразумевает чтение каждой строки и выполнение некоторого кода в каждой строке.
  • Более декларативным вариантом может быть запись формулы Excel в один из столбцов, а также копирование и вставка значений.

Тем не менее, он страдает от следующих ограничений:

• Это работает, выпуская инструкцию SQL. Если вы не знакомы с SQL, это может быть бесполезно для вас.
• Данные могут быть преобразованы только с помощью поддерживаемых SQL функций и управляющих операторов - без функций VBA.
• Этот подход не передает форматирование.
• INSERT INTO требует, чтобы источник и пункт назначения имели одинаковое количество полей с одинаковыми типами данных. (В этом случае SQL можно изменить, чтобы вставить в другой набор или порядок полей назначения и использовать другие исходные поля).
• Excel иногда запутывается в типах данных столбцов.
• Более новые версии Office (2010+) не позволяют вставлять / обновлять файл Excel с использованием чистого SQL. Вы получите следующее сообщение: Вы не можете редактировать это поле, потому что оно находится в связанной электронной таблице Excel. Возможность редактирования данных в связанной электронной таблице Excel была отключена в этом выпуске Access.
  • Все еще можно читать из входных файлов и создавать набор записей ADO из них. В Excel есть метод CopyFromRecordset, который может быть полезен вместо использования INSERT INTO,
  • Старому провайдеру Jet все еще разрешено делать это, но это означает только .xls вход и выход, нет .xlsx,
• При чтении имен рабочих листов через OpenSchema, если включен автофильтр, для каждой таблицы будет добавлена ​​дополнительная таблица - для 'Sheet1$', будут 'Sheet1$'FilterDatabase (или же Sheet1$_ при использовании провайдера Jet).

---

Добавьте ссылку (Инструменты -> Ссылки...) на объекты данных Microsoft ActiveX. (Выберите последнюю версию; обычно это 6.1).

Выходная рабочая книга и рабочий лист должны существовать. Кроме того, обе книги ввода и вывода должны быть закрыты во время выполнения этого кода.

Dim filepath As Variant
Dim outputFilePath As String
Dim outputSheetName As String

'To which file and sheet within the file should the output go?
outputFilePath = "c:\path\to\ouput.xls"
outputSheetName = "Sheet1"

For Each filepath In Application.GetOpenFilename(FileFilter:="Excel Files (*.xl*), *.xl*", MultiSelect:=True)
    Dim conn As New ADODB.Connection
    Dim schema As ADODB.Recordset
    Dim sql As String
    Dim sheetname As Variant

    With conn
        .Provider = "Microsoft.ACE.OLEDB.12.0"
        .ConnectionString = "Data Source=""" & filepath & """;" & _
            "Extended Properties=""Excel 12.0;HDR=No"""

        'To use the old Microsoft Jet provider:
        '.Provider = "Microsoft.Jet.OLEDB.4.0"
        '.ConnectionString = "Data Source=""" & filepath & """;" & _
        '    "Extended Properties=""Excel 8.0;HDR=No"""            

        .Open
    End With
    Set schema = conn.OpenSchema(adSchemaTables)
    For Each sheetname In schema.GetRows(, , "TABLE_NAME") 'returns a 2D array of one column
        'This appends the data into an existing worksheet
        sql = _
            "INSERT INTO [" & outputSheetName & "$] " & _
                "IN """ & outputFilePath & """ ""Excel 12.0;"" " & _
            "SELECT * " & _
            "FROM [" & sheetname & "]"

        'To create a new worksheet, use SELECT..INTO:
        'sql = _
        '    "SELECT * " & _
        '    "INTO [" & outputSheetName & "$] " & _
        '        "IN """ & outputFilePath & """ ""Excel 12.0;"" " & _
        '    "FROM [" & sheetname & "]"

        conn.Execute sql
    Next
Next

Dim wbk As Workbook
Set wbk = Workbooks.Open(outputFilePath)
wbk.Worksheets(outputSheetName).Coluns.AutoFit

---

Альтернативный подход заключается в чтении данных с помощью ADODB в набор записей, а затем вставке их в выходную книгу с помощью метода CopyFromRecordset:

Dim filepath As Variant
Dim outputFilePath As String
Dim outputSheetName As String
Dim sql As String
Dim wbk As Workbook, wks As Worksheet
Dim rng As Excel.Range
Dim sheetname As Variant

'To which file and sheet within the file should the output go?
outputFilePath = "c:\path\to\ouput.xlsx"
outputSheetName = "Sheet1"

For Each filepath In Application.GetOpenFilename(FileFilter:="Excel Files (*.xl*), *.xl*", MultiSelect:=True)
    Set schema = conn.OpenSchema(adSchemaTables)
    For Each sheetname In schema.GetRows(, , "TABLE_NAME") 'returns a 2D array of one column
        sql = sql & _
            "UNION ALL SELECT F1 " & _
            "FROM [" & sheetname & "]" & _
                "IN """ & filepath & """ ""Excel 12.0;"""
    Next
Next
sql = Mid(sql, 5) 'Gets rid of the UNION ALL from the first SQL

Dim conn As New ADODB.Connection
Dim rs As ADODB.Recordset
 With conn
    .Provider = "Microsoft.ACE.OLEDB.12.0"
    .ConnectionString = "Data Source=""" & filepath & """;" & _
        "Extended Properties=""Excel 12.0;HDR=No"""
    .Open
    Set rs = .Execute(sql)
    Set wbk = Workbooks.Open(outputFilePath, , True)
    Set wks = wbk.Sheets(outputSheetName)
    wks.Cells(2, 1).CopyFromRecordset rs
    wks.Columns.AutoFill
    .Close
End With

Jet SQL:

• INSERT INTO заявление
• В пункте

ADO:

• Использование ADO для запроса листа Excel
• Подключение к книге Excel с помощью ADO
• Метод OpenSchema
• Метод GetRows

Смотрите также этот ответ, который делает нечто подобное.

Answer 2

Вы можете попробовать это: https://msdn.microsoft.com/en-us/library/office/gg549168(v=office.14).aspx Я не знаю, поможет ли это.