Private Sub Worksheet_Change(ByVal Target As Range)
    Dim sh1, sh2 As Object
    Dim sCel As Range
    Dim First1 As String
    Dim LastRow As Long
    Set sh1 = Sheets("工作表1")
    Set sh2 = Sheets("工作表2")
    If Intersect(Target, sh2.[I1]) Is Nothing Then Exit Sub
    If Target = "" Then Exit Sub
    sh2.Range("H4:K" & sh2.Rows.Count & "").ClearContents    '清除先前搜尋的資料"
    sh1.Activate
    With sh1
        Set sCel = .[A:B].Find(What:=Target, LookAt:=xlPart)
        If sCel Is Nothing Then
            MsgBox ("未找到你要搜尋的資料"), vbCritical
            Exit Sub
        End If
        First1 = sCel.Address                          '保留第一個搜尋到的位址
        Do
            LastRow = sh2.Cells(sh2.Rows.Count, 8).End(xlUp).Row + 1
            sCel.Resize(1, 4).Copy sh2.Cells(LastRow, 8)
            Set sCel = .[A:B].FindNext(sCel)           '尋找下一個
        Loop Until First1 = sCel.Address               '下一個的位置=第一個的位置(回到第一個的位置)
    End With
    sh2.Activate
End Sub

Set sCel = [A:A].Find(What:=inTxt, LookAt:=xlWhole)

〔工作表１〕
再點選 取消搜尋
即可恢復原本未搜尋前的資料

Ａ：Ｄ欄即是原本資料，搜尋並未動到此部份，何來〔恢復原本未搜尋前的資料〕？？？

R = ActiveSheet.UsedRange.Rows.Count
If R > 3 Then Rows("4:" & R).Delete

For Each xSht In Sheets(Array("工作表1", "工作表3"))
　　Set xH = Range(Array("A4", "H4")(M))

M = M + 1: Jm = 0
　　With xSht
　　　　　For j = 4 To .Cells(Rows.Count, 1).End(xlUp).Row
　　　　　　　If InStr(.Cells(j, 1) & .Cells(j, 2), X) Then
　　　　　　　　　Jm = Jm + 1
　　　　　　　　　.Cells(j, 1).Resize(1, 4).Copy xH(Jm)
　　　　　　　End If

R > 3 Then Rows("4:" & R).Delete

注意：篩選狀態時，若不先解除篩選，任何操作都可能造成無法彌補的錯誤（尤其是已執行了儲存結果）

　　　.Sort Key1:=.Item(6), Order1:=xlAscending, Header:=xlYes, _
　　　　　　OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

Sub 排序()
Dim R&, LRR, Lm%, Lx%
R = [工作表1!A1].Cells(Rows.Count, 1).End(xlUp).Row
If R < 4 Then Exit Sub
　
LRR = Split("藍球_排球_棒球_足球_桌球", "_") 　'排序清單
With Application
　　　Lm = .GetCustomListNum(LRR) 　'檢查清單的位置
　　　If Lm = 0 Then .AddCustomList ListArray:=LRR 　'清單不存在,建立
　　　Lx = .GetCustomListNum(LRR) 　'取得清單位置序號
End With
　
With [工作表1!A3:F3].Resize(R - 2)
　　　.Select
　　　.Sort Key1:=.Item(6), Order1:=xlAscending, Header:=xlYes, _
　　　　　　OrderCustom:=Lx + 1, MatchCase:=False, Orientation:=xlTopToBottom
End With
　
If Lm = 0 Then Application.DeleteCustomList ListNum:=Lx 　'清單若是本次建立,刪除清單
End Sub