複数のワークシートから条件に一致する行を新しいシートにコピーするには、どうすればよいですか？

たとえば、下図のように同じ書式を持つ3 つのワークシートを含むブックがあるとします。このとき、列 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」という名前の新しいワークシートにコピー＆ペーストされます。下図をご参照ください。

---

---

関連するデータの取り込みまたはコピーに関する記事をさらに見る：