В этой статье мы создадим макрос для объединения нескольких областей на указанный лист.

Необработанные данные состоят из некоторых образцов данных, которые включают имя и возраст. У нас есть две области, которые содержат необработанные данные. Мы хотим объединить обе области на листе «Назначение».

ArrowMain

Нажатие кнопки «Копировать запись» выполнит объединение данных из обеих областей вместе с форматированием.

ArrowOutputRecord

Нажатие кнопки «Копировать только значение» также выполнит объединение данных из обеих областей, но без копирования формата ячейки.

ArrowOutputValuesOnly

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

For Each Smallrng In Sheets («Main»). Range («A9: B13, D16: E20»). Areas Next Smallrng Вышеупомянутый цикл For Each используется для циклического определения определенных областей.

Установите DestRange = Sheets («Destination»). Range («A» & LastRow)

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

Smallrng.Copy DestRange Приведенный выше код используется для копирования данных в указанное место назначения.

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

Option Explicit

Sub CopyMultiArea()

'Declaring variables

Dim DestRange As Range

Dim Smallrng As Range

Dim LastRow As Long

'Looping through specified areas

For Each Smallrng In Sheets("Main").Range("A9:B13,D16:E20").Areas



'Finding the row number of last cell

LastRow = Sheets("Destination").Range("A1").SpecialCells(xlLastCell).Row + 1



'Selecting the cell where records need to be copy

If LastRow = 2 Then

Set DestRange = Sheets("Destination").Range("A" & LastRow - 1)

Else

Set DestRange = Sheets("Destination").Range("A" & LastRow)

End If



'Copying records to specified destination range

Smallrng.Copy DestRange



Next Smallrng

End Sub

Sub CopyMultiAreaValues()

'Declaring variables

Dim DestRange As Range

Dim Smallrng As Range

Dim LastRow As Long

'Looping through specified areas

For Each Smallrng In Sheets("Main").Range("A9:B13,D16:E20").Areas



'Finding the row number of last cell

LastRow = Sheets("Destination").Range("A1").SpecialCells(xlLastCell).Row + 1



With Smallrng

'Selecting the cell where records need to be copy

If LastRow = 2 Then

Set DestRange = Sheets("Destination").Range("A" & LastRow - 1).Resize(.Rows.Count, .Columns.Count)

Else

Set DestRange = Sheets("Destination").Range("A" & LastRow).Resize(.Rows.Count, .Columns.Count)

End If

End With



'Assigning the values from source to destination

DestRange.Value = Smallrng.Value



Next Smallrng

End Sub

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

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