Как копировать строки с нескольких листов на новый лист по заданным критериям?

Предположим, у вас есть книга с тремя листами, имеющими одинаковое форматирование, как показано на рисунке ниже. Как быстро и легко скопировать все строки с этих листов, в которых столбец C содержит текст «Completed», на новый лист — без ручного копирования и вставки по одной строке?

Копирование строк из нескольких листов на основе критериев на новый лист с помощью кода VBA

---

Копирование строк из нескольких листов на основе критериев на новый лист с помощью кода VBA

Следующий код VBA поможет вам скопировать определённые строки со всех листов книги на новый лист в соответствии с заданным условием. Выполните следующие действия:

1. Удерживая нажатыми клавиши ALT + F11, откройте окно Microsoft Visual Basic для приложений.

2. Нажмите Вставка > Модуль и вставьте следующий код в окно модуля.

Код VBA: Копирование строк из нескольких листов на основе критериев на новый лист

Public Sub CopyRows_ValuesAndNumberFormats()
Dim xWs As Worksheet
Dim xCWs As Worksheet
Dim xRg As Range
Dim xStrName As String
Dim xRStr As String
Dim xRRg As Range
Dim xC As Integer
On Error Resume Next
Application.DisplayAlerts = False
xStr = "Kutools for Excel"
xRStr = "Completed"
Set xCWs = ActiveWorkbook.Worksheets.Item(xStr)
If Not xCWs Is Nothing Then
    xCWs.Delete
End If
Set xCWs = ActiveWorkbook.Worksheets.Add
xCWs.Name = xStr
xC = 1
For Each xWs In ActiveWorkbook.Worksheets
    If xWs.Name <> xStr Then
        Set xRg = xWs.Range("C:C")
        Set xRg = Intersect(xRg, xWs.UsedRange)
        For Each xRRg In xRg
            If xRRg.Value = xRStr Then
               xRRg.EntireRow.Copy
               xCWs.Cells(xC, 1).PasteSpecial xlPasteValuesAndNumberFormats
               xC = xC + 1
            End If
        Next xRRg
    End If
Next xWs
Application.DisplayAlerts = True
End Sub

Примечание: В приведённом выше коде:

• Текст «Completed» в этом xRStr = «Completed»сценарии указывает конкретное условие, на основе которого необходимо копировать строки;
• C:C в этом Set xRg = xWs.Range(«C:C») сценарии указывает столбец, в котором расположено условие.

3. Затем нажмите клавишу F5, чтобы запустить этот код. Все строки, соответствующие заданному условию, будут скопированы и вставлены на новый лист с именем «Kutools для Excel» в текущей книге. См. рисунок:

---

---

Другие статьи по извлечению или копированию данных: