Объединить книги Excel в один лист

Question

Я пытаюсь объединить 250 книг Excel по базам данных в один непрерывный лист. Все книги имеют одинаковый тип данных с одинаковыми заголовками.

Я пытался использовать этот код VBA:

Sub mergeFiles () 'Объединяет все файлы в папке с основным file.

'Define variables:
Dim numberOfFilesChosen, i As Integer
Dim tempFileDialog As fileDialog
Dim mainWorkbook, sourceWorkbook As Workbook
Dim tempWorkSheet As Worksheet

Set mainWorkbook = Application.ActiveWorkbook
Set tempFileDialog = Application.fileDialog(msoFileDialogFilePicker)

'Allow the user to select multiple workbooks
tempFileDialog.AllowMultiSelect = True

numberOfFilesChosen = tempFileDialog.Show

'Loop through all selected workbooks
For i = 1 To tempFileDialog.SelectedItems.Count

    'Open each workbook
    Workbooks.Open tempFileDialog.SelectedItems(i)

    Set sourceWorkbook = ActiveWorkbook

    'Copy each worksheet to the end of the main workbook
    For Each tempWorkSheet In sourceWorkbook.Worksheets
        tempWorkSheet.Copy after:=mainWorkbook.Sheets(mainWorkbook.Worksheets.Count)
    Next tempWorkSheet

    'Close the source workbook
    sourceWorkbook.Close
Next i

End Sub

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

Answer 1

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

1. Скопируйте эти новые объявления в область ваших объявлений:

   Dim sh As Worksheet, arrCopy As Variant, lastR As Long

2. Скопируйте эту строку кода перед l oop (For i = 1 To ...):

   Set sh = mainWorkbook.Sheets(mainWorkbook.Worksheets.count) 'You can use here your sheet where the data will be collected. I used the last sheet for easy testing reason

3. Заменить (в l oop For Each ...) существующий код (tempWorkSheet.Copy after:=mainWorkbook.Sheets(mainWorkbook.Worksheets.Count)) на следующий:

   lastR = sh.Range("A" & sh.Rows.count).End(xlUp).row

   arrCopy = tempWorkSheet.Range(tempWorkSheet.Range("A" & IIf(lastR = 1, 1, 2)), _ tempWorkSheet.Range("A1").SpecialCells(xlLastCell)).Value sh.Range("A" & lastR + IIf(lastR = 1, 0, 1)).Resize(UBound(arrCopy, 1), _ UBound(arrCopy, 2)).Value = arrCopy

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

Ваш полный код как и должно быть для работы (не проверено):

Sub mergeFiles()
'Define variables:
Dim numberOfFilesChosen, i As Integer
Dim tempFileDialog As FileDialog
Dim mainWorkbook, sourceWorkbook As Workbook
Dim sh As Worksheet, arrCopy As Variant, lastR As Long
Dim tempWorkSheet As Worksheet, lastRtemp As Long

Set mainWorkbook = Application.ActiveWorkbook
Set tempFileDialog = Application.FileDialog(msoFileDialogFilePicker)

'Allow the user to select multiple workbooks
tempFileDialog.AllowMultiSelect = True

numberOfFilesChosen = tempFileDialog.Show

'You can use here your sheet where the data will be collected. I used the last sheet for easy testing reason
Set sh = mainWorkbook.Sheets(mainWorkbook.Worksheets.count)

    'Loop through all selected workbooks
    For i = 1 To tempFileDialog.SelectedItems.count

        'Open each workbook
        Workbooks.Open tempFileDialog.SelectedItems(i)

        Set sourceWorkbook = ActiveWorkbook

        'Copy each worksheet to the end of the main workbook
        Set tempWorkSheet = sourceWorkbook.Worksheets(1)
            lastR = sh.Range("A" & sh.Rows.count).End(xlUp).row
            lastRtemp = tempWorkSheet.Range("A" & tempWorkSheet.Rows.count).End(xlUp).row
            If lastRtemp < 2 Then
                MsgBox "The workbook " & tempWorkSheet.Name & " contains less the two rows..."
            Else
                arrCopy = tempWorkSheet.Range(tempWorkSheet.Range("A" & IIf(lastR = 1, 1, 2)), _
                  tempWorkSheet.Range("A1").SpecialCells(xlLastCell)).Value
                sh.Range("A" & lastR + IIf(lastR = 1, 0, 1)).Resize(UBound(arrCopy, 1), _
                                        UBound(arrCopy, 2)).Value = arrCopy
            End If

        'Close the source workbook
        sourceWorkbook.Close
    Next i
End Sub

Answer 2

Я использовал следующий макрос, чтобы объединить множество файлов CSV в одном листе в новой книге. Возможно, вам придется внести некоторые изменения в соответствии с вашими потребностями

Sub GetFromCSVs()
  Dim WB As Workbook
  Dim R As Range
  Dim bFirst As Boolean
  Dim stFile As String
  Dim stPath As String
  stPath = "D:\CSV Files\" ' change the path to suit
  stFile = Dir(stPath & "*.csv")
  'bFirst = True
  Set R = Workbooks.Add(xlWorksheet).Sheets(1).Range("A1")
  Do Until stFile = ""
    Set WB = Workbooks.Open(stPath  & stFile, ReadOnly:=True)
    'If bFirst Then
     ' WB.Sheets(1).Range("A1").CurrentRegion.Copy Destination:=R
      WB.Sheets(1).Range(Selection, Range("A1").SpecialCells(xlLastCell)).Copy Destination:=R
      Set R = R.Offset(R.SpecialCells(xlLastCell).Row + 1 - R.Row, 0)

      'Set R = Range("A1").Offset(ActiveCell.SpecialCells(xlLastCell).Row, 0)
      'bFirst = False
    'Else
      'WB.Sheets(1).Range("A1").CurrentRegion.Columns(2).Copy Destination:=R
      'Set R = R.Offset(, 1)
    'End If
    WB.Close saveChanges:=False
    stFile = Dir()  ' next file
  Loop
End Sub