【VBA】重複データを部分一致で抽出する方法

Option Explicit
Sub ExtractPartialMatchDuplicates()
    Dim ws As Worksheet, wsResult As Worksheet
    Dim lastRow As Long, i As Long, j As Long
    Dim dict As Object
    Set ws = ThisWorkbook.Sheets("Sheet1")
    Set wsResult = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
    wsResult.Name = "ExtractedDuplicates"
    Application.ScreenUpdating = False
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    Set dict = CreateObject("Scripting.Dictionary")
    For i = 2 To lastRow
        If Not dict.exists(ws.Cells(i, 1)) Then
            dict.Add ws.Cells(i, 1), 0
        Else
            dict(ws.Cells(i, 1)) = dict(ws.Cells(i, 1)) + 1
        End If
    Next i
    For i = 2 To lastRow
        If dict(ws.Cells(i, 1)) > 0 Then
            wsResult.Cells(wsResult.Rows.Count, 1).End(xlUp).Offset(1, 0) = ws.Cells(i, 1)
        End If
    Next i
    Application.ScreenUpdating = True
End Sub