vba利用自动筛选按任意列拆分成多工作表

Option Explicit

Sub main()
    Dim colNo As Integer, sht As Worksheet, lastRow As Long, i As Long, flag As Boolean
    colNo = InputBox("col no:")
        
    Excel.Application.DisplayAlerts = False
    For Each sht In Sheets
        If sht.Name <> Sheet1.Name Then sht.Delete
    Next
    Excel.Application.DisplayAlerts = True
    
    lastRow = Sheet1.Range("A1000000").End(xlUp).Row
    
    For i = 2 To lastRow
        flag = False
        For Each sht In Sheets
            If sht.Name = Sheet1.Cells(i, colNo) Then
                flag = True
                Exit For
            End If
        Next
        
        If Not flag Then
            Sheets.Add(after:=Sheets(Sheets.Count)).Name = Sheet1.Cells(i, colNo).Value
            Sheet1.UsedRange.AutoFilter field:=colNo, Criteria1:=Sheet1.Cells(i, colNo).Value
            Sheet1.UsedRange.Copy Sheets(Sheets.Count).[A1]
        End If
    Next
    
    Sheet1.UsedRange.AutoFilter
    
End Sub

 

Option Explicit

Sub main()
    Dim lineNo As Integer, keys, dict, i As Integer
    lineNo = InputBox("input line no")
    
    Set dict = GetItems(Sheet1, lineNo)
    keys = dict.keys
    Call DeleteSheets
    
    For i = 0 To dict.Count - 1
        Sheets.Add after:=Sheets(Sheets.Count)
        Sheets(Sheets.Count).Name = keys(i)
        
        Sheet1.UsedRange.AutoFilter field:=lineNo, Criteria1:=keys(i)
        Sheet1.UsedRange.Copy Sheets(Sheets.Count).Range("A1")
        
    Next
    
    Sheet1.UsedRange.AutoFilter
    
End Sub

Function GetItems(sht As Worksheet, lineNo As Integer)
    Dim d As Object, i As Integer
    Set d = CreateObject("Scripting.Dictionary")
    For i = 2 To sht.Range("A65536").End(xlUp).Row
        If Not d.exists(sht.Cells(i, lineNo).Value) Then
             d.Add Key:=sht.Cells(i, lineNo).Value, Item:=sht.Cells(i, lineNo).Value
        End If
    Next
    Set GetItems = d
End Function


Sub DeleteSheets()
    Dim i As Integer
    Excel.Application.DisplayAlerts = False
    For i = Sheets.Count To 2 Step -1
        Sheets(i).Delete
    Next
    Excel.Application.DisplayAlerts = True
End Sub