VBA为每个条件在特定列中自动过滤并将结果复制到新工作表

Question

您能否帮助通过 VBA 自动执行以下任务。

需要过滤每个区域（F 列）并将结果复制到新工作表。如果这可以通过循环来完成，那将很有帮助，因为原始数据集包含更多区域。感谢您的帮助

F 列（前 10 个单元格）：东西北 南 南 南 西 北

Answer 1

这应该适合你

Sub filter_copy()
    Dim strfilterrng As String
    Dim col As Long
    Dim mainsheet As String
    mainsheet = ActiveSheet.Name
    col = 6
    strfilterrng = find_filter_range()
    lc = get_last_row_in_column(col)
    Dim r As Range
    Set r = ActiveSheet.Range(strfilterrng)
    x = r.Columns.Count()
    arr = GetUnique(ActiveSheet.Range(ActiveSheet.Cells(r.Cells.Item(1).Row + 1, col).Address & ":" & ActiveSheet.Cells(lc, col).Address))
    For Index = LBound(arr) To UBound(arr)
    ActiveSheet.Range(strfilterrng).AutoFilter Field:=col - x, Criteria1:=arr(Index)
    ActiveSheet.UsedRange.SpecialCells(xlCellTypeVisible).Select
    Selection.Copy
    Sheets.Add After:=ActiveSheet
    ActiveSheet.Paste
    Sheets(mainsheet).Select
    Next Index
    Range("A1").Select
End Sub

Function find_filter_range() As String
    Dim sh As Worksheet
    Set sh = ActiveSheet
    If sh.AutoFilterMode = True Then
        find_filter_range = sh.AutoFilter.Range.Address
    Else
        sh.UsedRange.AutoFilter
        find_filter_range = sh.AutoFilter.Range.Address
    End If
End Function

Function get_last_row_in_column(ByVal columnnum As Long) As Long
    get_last_row_in_column = ActiveSheet.Cells(Rows.Count, columnnum).End(xlUp).Row
End Function

Function GetUnique(ByRef rng As Range) As Variant
    Dim d As Object, k, tmp As String, i As Long, arr() As Variant
    Set d = CreateObject("scripting.dictionary")
    For Each c In rng
        tmp = Trim(c.Value)
        If Len(tmp) > 0 Then d(tmp) = d(tmp) + 1
    Next c

    i = 0
    For Each k In d.keys
        ReDim Preserve arr(0 To i)
        arr(i) = k
        i = i + 1
    Next k
    GetUnique = arr
End Function