В этой статье мы создадим макрос для копирования данных из нескольких книг в папке в новую книгу.

Мы создадим два макроса; один макрос будет копировать только записи из первого столбца в новую книгу, а второй макрос скопирует в нее все данные.

Необработанные данные для этого примера состоят из записей посещаемости сотрудников.

В TestFolder у нас есть несколько файлов Excel. Имена файлов Excel представляют собой конкретную дату в формате «ддммйгг».

ArrowFilesSource

Каждый файл Excel содержит дату, идентификатор сотрудника и имена сотрудников, которые присутствовали в этот конкретный день.

ArrowRawFile

Мы создали два макроса; «CopyingSingleColumnData» и «CopyingMultipleColumnData». Макрос CopyingSingleColumnData копирует только записи из первого столбца всех файлов в папке в новую книгу. Макрос CopyingMultipleColumnData скопирует все данные из всех файлов в папке в новую книгу.

Макрос «CopyingSingleColumnData» можно запустить, нажав кнопку «Копирование одного столбца». Макрос «CopyingMultipleColumnData» можно запустить, нажав кнопку «Копирование нескольких столбцов».

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

ArrowMain

При нажатии кнопки «Копирование одного столбца» в указанной папке будет создана новая книга «ConsolidatedFile». Эта книга будет содержать консолидированные данные из первого столбца всех файлов в папке.

ArrowAfterRunningSingleColumnMacro

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

ArrowOutputAfterRunningSingleMacro

При нажатии кнопки «Копирование нескольких столбцов» создается новая рабочая книга «ConsolidatedAllColumns» в указанной папке. Эта книга будет содержать консолидированные данные из всех записей всех файлов в папке.

ArrowRunningSecondMacro

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

ArrowFileAfterRunningSecondMacro

Объяснение кода

Sheet1.TextBox1.Value Приведенный выше код используется для получения значения, вставленного в текстовое поле «TextBox1» из листа «Sheet1».

Dir (FolderPath & «* .xlsx»)

Приведенный выше код используется для получения имени файла с расширением «.xlsx». Мы использовали подстановочный знак * для многосимвольного имени файла.

Хотя FileName <> «»

Count1 = Count1 + 1 ReDim Preserve FileArray (1 To Count1)

FileArray (Count1) = FileName FileName = Dir ()

Код Wend Above используется для получения имен всех файлов в папке.

Для i = 1 To UBound (FileArray)

Далее Приведенный выше код используется для перебора всех файлов в папке.

Range («A1», Cells (LastRow, 1)). Скопируйте DestWB.ActiveSheet.Cells (LastDesRow, 1)

Приведенный выше код используется для копирования записи из первого столбца в целевую книгу.

Range («A1», ActiveCell.SpecialCells (xlCellTypeLastCell)). Копировать DestWB.ActiveSheet.Cells (LastDesRow, 1)

Приведенный выше код используется для копирования всей записи из активной книги в целевую книгу.

Пожалуйста, введите код ниже

Option Explicit

Sub CopyingSingleColumnData()

'Declaring variables

Dim FileName, FolderPath, FileArray(), FileName1 As String

Dim LastRow, LastDesRow, Count1, i As Integer

Dim SourceWB, DestWB As Workbook

Application.ScreenUpdating = False

FolderPath = Sheet1.TextBox1.Value

'Inserting backslash in the folder path if backslash(\) is missing

If Right(FolderPath, 1) <> "\" Then

FolderPath = FolderPath & "\"

End If

'Searching for Excel files

FileName = Dir(FolderPath & "*.xlsx")

Count1 = 0

'Looping through all the Excel files in the folder

While FileName <> ""

Count1 = Count1 + 1

ReDim Preserve FileArray(1 To Count1)

FileArray(Count1) = FileName

FileName = Dir()

Wend

'Creating a new workbook

Set DestWB = Workbooks.Add

For i = 1 To UBound(FileArray)

'Finding the last row in the workbook

LastDesRow = DestWB.ActiveSheet.Range("A1").SpecialCells(xlCellTypeLastCell).Row

'Opening the Excel workbook

Set SourceWB = Workbooks.Open(FolderPath & FileArray(i))

LastRow = ActiveCell.SpecialCells(xlCellTypeLastCell).Row

'Pasting the copied data to last row in the destination workbook

If LastDesRow = 1 Then

'Copying the first column to last row in the destination workbook

Range("A1", Cells(LastRow, 1)).Copy DestWB.ActiveSheet.Cells(LastDesRow, 1)

Else

Range("A1", Cells(LastRow, 1)).Copy DestWB.ActiveSheet.Cells(LastDesRow + 1, 1)

End If

SourceWB.Close False

Next

'Saving and closing a new Excel workbook

DestWB.SaveAs FileName:=FolderPath & "ConsolidatedFile.xlsx"

DestWB.Close

Set DestWB = Nothing

Set SourceWB = Nothing

End Sub

Sub CopyingMultipleColumnData()

'Declaring variables

Dim FileName, FolderPath, FileArray(), FileName1 As String

Dim LastRow, LastDesRow, Count1, i As Integer

Dim SourceWB, DestWB As Workbook

Application.ScreenUpdating = False

FolderPath = Sheet1.TextBox1.Value

'Inserting backslash in the folder path if backslash(\) is missing

If Right(FolderPath, 1) <> "\" Then

FolderPath = FolderPath & "\"

End If

'Searching for Excel files

FileName = Dir(FolderPath & "*.xlsx")

Count1 = 0

'Looping through all the Excel files in the folder

While FileName <> ""

Count1 = Count1 + 1

ReDim Preserve FileArray(1 To Count1)

FileArray(Count1) = FileName

FileName = Dir()

Wend

'Creating a new workbook

Set DestWB = Workbooks.Add

For i = 1 To UBound(FileArray)

'Finding the last row in the workbook

LastDesRow = DestWB.ActiveSheet.Range("A1").SpecialCells(xlCellTypeLastCell).Row

'Opening the Excel workbook

Set SourceWB = Workbooks.Open(FolderPath & FileArray(i))

'Pasting the copied data to last row in the destination workbook

If LastDesRow = 1 Then

'Copying all data in the worksheet to last row in the destination workbook

Range("A1", ActiveCell.SpecialCells(xlCellTypeLastCell)).Copy DestWB.ActiveSheet.Cells(LastDesRow, 1)

Else

Range("A1", ActiveCell.SpecialCells(xlCellTypeLastCell)).Copy DestWB.ActiveSheet.Cells(LastDesRow + 1, 1)

End If

SourceWB.Close False

Next

'Saving and closing a new Excel workbook

DestWB.SaveAs FileName:=FolderPath & "ConsolidatedAllColumns.xlsx"

DestWB.Close

Set DestWB = Nothing

Set SourceWB = Nothing

End Sub

Если вам понравился этот блог, поделитесь им с друзьями на Facebook и Facebook.

Мы будем рады услышать от вас, дайте нам знать, как мы можем улучшить нашу работу и сделать ее лучше для вас. Напишите нам на [email protected]