如何根据指定条件，从多个工作表中将符合条件的行复制到新工作表？

假设您有一个工作簿，其中包含三个格式相同的如下图所示的工作表。现在，您希望将这些工作表中 C 列包含“Completed”文本的所有行快速复制到一个新工作表中。如何高效轻松地实现这一操作，而无需手动逐个复制粘贴？

使用 VBA 代码根据条件将多个工作表中的行复制到新工作表

---

使用 VBA 代码根据条件将多个工作表中的行复制到新工作表

以下 VBA 代码可助您根据特定条件，将工作簿中所有工作表的指定行高效汇总至一个全新工作表。请按以下步骤操作：

1. 按住 ALT + F11 键，即可打开 Microsoft Visual Basic for Applications 窗口。

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"。
• Set xRg = xWs.Range("C:C") 中的 C:C 表示条件所在的指定列。

3. 然后，按 F5 键运行此代码，所有符合条件的行将自动复制并粘贴到当前工作簿中名为“Kutools for Excel”的新工作表内。参见下图：

---

---

更多相关的提取或复制数据文章：