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

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

ArrowRawData

Мы создали макрос CopyRangeFromMultipleSheets для консолидации данных. Этот макрос можно запустить, нажав кнопку «Объединить данные».

ArrowMain

Макрос создаст новый рабочий лист и вставит консолидированные данные со всех рабочих листов.

ArrowOutput

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

«Циклический просмотр» всех листов, чтобы проверить, существует ли «мастер-лист».

Для каждого источника в ThisWorkbook.Worksheets Если Source.Name = «Master», то MsgBox «Мастер-лист уже существует»

Exit Sub End If Next Above code используется для проверки того, существует ли в книге «Мастер» лист. Если в книге существует «Мастер» лист, то код завершается и отображается сообщение об ошибке.

Source.Range («A1»). SpecialCells (xlLastCell) .Row Вышеуказанный код используется для получения номера строки последней ячейки на листе.

Source.Range («A1», Range («A1»). SpecialCells (xlLastCell)). Копировать Destination.Range («A» & DestLastRow)

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

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

Sub CopyRangeFromMultipleSheets()

'Declaring variables

Dim Source As Worksheet

Dim Destination As Worksheet

Dim SourceLastRow, DestLastRow As Long

Application.ScreenUpdating = False

'Looping through all sheets to check whether "Master" sheet exist

For Each Source In ThisWorkbook.Worksheets

If Source.Name = "Master" Then

MsgBox "Master sheet already exist"

Exit Sub

End If

Next

'Inserting a new sheet after the "Main" sheet

Set Destination = Worksheets.Add(after:=Sheets("Main"))

Destination.Name = "Master"

'Looping through all the sheets in the workbook

For Each Source In ThisWorkbook.Worksheets



'Preventing consolidation of data from "Main" and "Master" sheet

If Source.Name <> "Main" And Source.Name <> "Master" Then



SourceLastRow = Source.Range("A1").SpecialCells(xlLastCell).Row



Source.Activate



If Source.UsedRange.Count > 1 Then



DestLastRow = Sheets("Master").Range("A1").SpecialCells(xlLastCell).Row



If DestLastRow = 1 Then

'copying data from the source sheet to destination sheet

Source.Range("A1", Range("A1").SpecialCells(xlLastCell)).Copy Destination.Range("A" & DestLastRow)

Else

Source.Range("A2", Range("A1").SpecialCells(xlCellTypeLastCell)).Copy Destination.Range("A" & (DestLastRow + 1))

End If



End If

End If

Next

Destination.Activate

Application.ScreenUpdating = True

End Sub

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

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