如何根據特定條件，從多個工作表中將指定欄位複製到新工作表？

假設您有一個活頁簿，其中包含三個格式如下圖所示的工作表。現在，您希望將這些工作表中欄位 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"指令碼中表示您要據以複製列的特定條件；
• C:C 在此 Set xRg = xWs.Range("C:C")指令碼中，表示指定條件所在的欄位。

3. 接著按下 F5 鍵執行此程式碼，所有符合特定條件的列便會自動複製並貼上至目前工作簿中名為「Kutools for Excel」的新工作表。請參閱下圖：

---

---

更多相關的提取或複製資料文章：