Excel VBA：資料篩選、進階篩選

假日幫網友處理一個跟保險有關的案例，初步需求是要從資料去篩選出姓名，當使用者用姓名篩選後，找出其他相關的人跟地址，該網友本身有寫VBA程式碼，但每天執行需要40分鐘~1小時，需求是需要能優化過程，目前以網路公開資料來進行操作，資料來源為 地方公職人員資訊服務網，從這裡下載資料在進行修改與模擬該相關需求。
由於資料僅有一張表(如：檔案連結中的工作表：「全部資料」)，僅能以此作為查詢依據，至於其真實性這裡將不作考究，只針對需求來做說明。
需求內容如下：

1. 以「姓名」選出相關的「地址」，該「地址」可能會出現於資料中其他行，且會是另一人的「姓名」。
2. 再以另一人的「姓名」選出其他相關的「地址」，相同方式循環找，直到所有相關「姓名」與「地址」都不在新增為止。

基於以上需求內容，我將藉由篩選方式來減少迴圈的使用，搭配「高階篩選」、「移除重複」、「資料驗證」等，程式碼來處理。

程式運作流程：

1. 檔案開啟時，觸發「Workbook_Open」事件對「鄉鎮市」進行過濾，過濾並移除重複數值，用以建立第一層資料清單。
2. 當使用者對「鄉鎮市」切換時，觸發「Workbook_SheetChange」事件，在指定工作表與儲存格位置後，可針對「鄉鎮市」挑選出不重複的「姓名」作為清單。
3. 當使用者對「姓名」切換，觸發「Workbook_SheetChange」事件，在「全部資料」進行篩選查詢。
4. 選出來後再逐一以「地址」進行查詢其他相關「姓名」。
5. 「姓名」選出後再以「姓名」查詢「地址」，如此循環直到不在出現新的「姓名」或「地址」為止。

以下就是檔案中相關的程式碼。
在VBE的ThisWorkbook中貼上以下程式碼。

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Workbooks(1).Sheets(1).Cells.Clear
    Workbooks(1).Save
End Sub

Private Sub Workbook_Open()
    第一層清單產生
End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    If Sh.Name = "資料顯示" Then
        If Target.Address = "$A$1" Then
            第二層清單產生
        ElseIf Target.Address = "$B$1" Then
            If Len(Sh.Range(Target.Address)) Then
                以姓名過濾出地址
                Do
                以地址選出親屬
                Loop While 以親屬姓名選出地址
                
                最後結果傳至第一張工作表
            End If
        End If
    End If
End Sub

在VBE添加Module1並貼上以下程式碼。

Sub 第一層清單產生()
    Dim listcount1 As Integer
    
    Workbooks(1).Sheets(3).Columns(1).Clear
    
    '進階過濾篩選出不重複的鄉鎮市
    With Workbooks(1).Sheets(2)
        .Range("C:C").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Workbooks(1).Sheets(3).Range("A1"), Unique:=True
    End With
    
    '賦予資料區域名稱為list1，等於是名稱管理員的設定
    With Workbooks(1).Sheets(3)
        .Range(Cells(2, "A").Address, .Cells(Rows.count, "A").End(xlUp).Address).Name = "list1"
    End With
    
    '設定"資料驗證"中的清單
    With Workbooks(1).Sheets(1).Range("A1").Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
             Operator:=xlBetween, Formula1:="=list1"
    End With
End Sub

Sub 第二層清單產生()
    Dim listcount1 As Integer
    
    Workbooks(1).Sheets(3).Columns(2).Clear
    
    以鄉鎮市過濾出姓名
    
    '進階過濾篩選出不重複的姓名
    With Workbooks(1).Sheets(4)
        .Range("A:A").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Workbooks(1).Sheets(3).Range("B1"), Unique:=True
        .Cells.Clear
    End With
    
    '賦予資料區域名稱為list2，等於是名稱管理員的設定
    With Workbooks(1).Sheets(3)
        .Range(Cells(2, "B").Address, .Cells(Rows.count, "B").End(xlUp).Address).Name = "list2"
    End With
    
    '設定"資料驗證"中的清單
    With Workbooks(1).Sheets(1).Range("B1")
        .Clear
        With .Validation
            .Delete
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
                 Operator:=xlBetween, Formula1:="=list2"
        End With
    End With
End Sub

Sub 以鄉鎮市過濾出姓名()
    Dim tmp, line
    Dim i As Integer, count As Integer
    
    With Workbooks(1).Sheets(2)
        With .UsedRange
            '鄉鎮市篩選
            .AutoFilter Field:=.Cells(1, "C").column, Criteria1:="=" & Sheets(1).Cells(1, 1)
            
            '選出符合條件的資料
            Set tmp = .Resize(.Rows.count - 1).SpecialCells(xlCellTypeVisible)
            count = 1
            For Each line In tmp.Areas
                For i = 1 To line.Rows.count
                    Sheets(4).Cells(count, 1).Value = line(i, 5).Value
                    count = count + 1
                Next
            Next
        End With
        
        '關閉篩選
        .AutoFilterMode = False
    End With
End Sub

Sub 以姓名過濾出地址()
    Dim tmp, line
    Dim i As Integer, j As Integer, count As Integer, column As Integer
    
    Workbooks(1).Sheets(4).Cells.Clear
    With Workbooks(1).Sheets(2)
        column = .Cells(1, Columns.count).End(xlToLeft).column
        With .UsedRange
            '姓名篩選
            .AutoFilter Field:=.Cells(1, "E").column, Criteria1:="=" & Sheets(1).Cells(1, 2)
            
            '選出符合條件的資料
            Set tmp = .Resize(.Rows.count - 1).SpecialCells(xlCellTypeVisible)
            count = 1
            For Each line In tmp.Areas
                For i = 1 To line.Rows.count
                    For j = 1 To column
                        Sheets(4).Cells(count, j).Value = line(i, j).Value
                    Next
                    
                    '取得符合條件的資料所在列位置
                    Sheets(4).Cells(count, column + 1).Value = line.Rows.row() + i - 1
                    If line.Rows.row() = 1 And Sheets(4).Cells(count, column + 1) = 1 Then
                        Sheets(4).Cells(count, column + 1) = "行號"
                    End If
                    count = count + 1
                Next
            Next
        End With
        
        '關閉篩選
        .AutoFilterMode = False
    End With
End Sub

Sub 以地址選出親屬()
    Dim tmp, line
    Dim i As Integer, j As Integer, k As Integer, count As Integer, column As Integer, row As Integer
    
    With Workbooks(1).Sheets(2)
        column = .Cells(1, Columns.count).End(xlToLeft).column
        With .UsedRange
            row = Sheets(4).Cells(Rows.count, 1).End(xlUp).row
            count = row + 1
            For k = 2 To row
                '地址篩選
                .AutoFilter Field:=.Cells(1, "G").column, Criteria1:="=" & Sheets(4).Cells(k, 7)
                
                '選出符合條件的資料
                Set tmp = .Offset(1).Resize(.Rows.count - 1).SpecialCells(xlCellTypeVisible)
                For Each line In tmp.Areas
                    For i = 1 To line.Rows.count
                        For j = 1 To column
                            Sheets(4).Cells(count, j).Value = line(i, j).Value
                        Next
                        
                        '取得符合條件的資料所在列位置
                        Sheets(4).Cells(count, column + 1).Value = line.Rows.row() + i - 1
                        count = count + 1
                    Next
                Next
            Next
        End With
        
        '關閉篩選
        .AutoFilterMode = False
    End With
    
    '針對重複資料進行移除
    row = Workbooks(1).Sheets(4).Cells(Rows.count, 1).End(xlUp).row
    column = Workbooks(1).Sheets(4).Cells(1, Columns.count).End(xlToLeft).column
    
    ReDim col(0 To column - 1)
    For i = 0 To column - 1
        col(i) = i + 1
    Next
    Workbooks(1).Sheets(4).Range("A1:J" & row).RemoveDuplicates Columns:=(col), Header:=xlYes
    Workbooks(1).Sheets(3).Cells(1, 30) = Workbooks(1).Sheets(4).Cells(Rows.count, 1).End(xlUp).row
End Sub

Function 以親屬姓名選出地址()
    Dim tmp, line
    Dim i As Integer, j As Integer, k As Integer, count As Integer, column As Integer, row As Integer
    
    With Workbooks(1).Sheets(2)
        column = .Cells(1, Columns.count).End(xlToLeft).column
        With .UsedRange
            row = Sheets(4).Cells(Rows.count, 1).End(xlUp).row
            count = row + 1
            For k = 2 To row
                '親屬姓名篩選
                .AutoFilter Field:=.Cells(1, "E").column, Criteria1:="=" & Sheets(4).Cells(k, 5)
                
                '選出符合條件的資料
                Set tmp = .Offset(1).Resize(.Rows.count - 1).SpecialCells(xlCellTypeVisible)
                For Each line In tmp.Areas
                    For i = 1 To line.Rows.count
                        For j = 1 To column
                            Sheets(4).Cells(count, j).Value = line(i, j).Value
                        Next
                        
                        '取得符合條件的資料所在列位置
                        Sheets(4).Cells(count, column + 1).Value = line.Rows.row() + i - 1
                        count = count + 1
                    Next
                    
                Next
            Next
        End With
        
        '關閉篩選
        .AutoFilterMode = False
    End With
    
    '針對重複資料進行移除
    row = Workbooks(1).Sheets(4).Cells(Rows.count, 1).End(xlUp).row
    Workbooks(1).Sheets(4).Range("A1:J" & row).RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10), Header:=xlYes
    
    以親屬姓名選出地址 = False
    Workbooks(1).Sheets(3).Cells(1, 31) = Workbooks(1).Sheets(4).Cells(Rows.count, 1).End(xlUp).row
    If Workbooks(1).Sheets(3).Cells(1, 30) <> Workbooks(1).Sheets(3).Cells(1, 31) Then
        以親屬姓名選出地址 = True
    End If
End Function

Sub 最後結果傳至第一張工作表()
    Dim row As Integer, column As Integer
    
    With Workbooks(1).Sheets(1)
        row = .Cells(Rows.count, 1).End(xlUp).row
        If row < 5 Then row = 5
        .Rows("5:" & row).Clear
    End With
    
    With Workbooks(1).Sheets(4)
        row = .Cells(Rows.count, 1).End(xlUp).row
        column = .Cells(1, Columns.count).End(xlToLeft).column
        Workbooks(1).Sheets(1).Cells(5, 1).Resize(row, column).Value = .Cells(1, 1).Resize(row, column).Value
    End With
End Sub

執行結果：

檔案連結。