excel - 过滤范围复制粘贴值并创建新工作表

Question

我一直在尝试找到一种使用特定列数据创建多个工作表的方法。
如果 Col"A"有多个重复条目，则过滤单个值使用该值名称创建新工作表，复制所有数据并粘贴到新添加的工作表中。
我无法用语言详细说明这件事，对不起我的英语不好，我附上了一个示例工作簿。
Sheet1 使用 Column A 代码的数据将创建多个工作表。您的帮助将不胜感激。

Sub CopyPartOfFilteredRange()
    Dim src As Worksheet
        Dim tgt As Worksheet
        Dim filterRange As Range
        Dim copyRange As Range
        Dim lastRow As Long
    
        Set src = ThisWorkbook.Sheets("Sheet1")
        Set tgt = ThisWorkbook.Sheets("Sheet8")
    
        src.AutoFilterMode = False
    
        lastRow = src.Range("A" & src.Rows.Count).End(xlUp).Row
    
        Set filterRange = src.Range("A1:A" & lastRow)
    
        Set copyRange = src.Range("A1:P" & lastRow)
    
        filterRange.AutoFilter field:=1, Criteria1:="CC"
    
        copyRange.SpecialCells(xlCellTypeVisible).Copy tgt.Range("A1")
    
    End Sub

数据表

CC 新表

DD 新表

Till the last value HH

Answer 1

请测试下一个改编的代码:

Sub CopyPartOfFilteredRange()
    Dim src As Worksheet, tgt As Worksheet, copyRange As Range, filterRange As Range, lastRow As Long
    Dim dict As Object, filterArr, i As Long
    
        Set src = ActiveSheet ' ActiveWorkbook.Sheets("Sheet1")
        lastRow = src.Range("A" & src.rows.count).End(xlUp).row
        Set copyRange = src.Range("A1:P" & lastRow)
        Set filterRange = src.Range("A2:A" & lastRow) 'it assumes that there are headers on the first row
        filterArr = filterRange.value   'place it in an array for faster iteration
        
        Set dict = CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(filterArr)
            If filterArr(i, 1) <> "" Then dict(filterArr(i, 1)) = 1 'extract uniques strings
        Next
        filterArr = dict.Keys        'unique strings to be used in filterring
        'some optimization:
        With Application
            .ScreenUpdating = False
            .EnableEvents = False
            .Calculation = xlCalculationManual
        End With
        For i = 0 To UBound(filterArr)
            src.AutoFilterMode = False
            'insert the new sheet and name it as filterr criteria, or use the existing one, if any:
            On Error Resume Next
             Set tgt = ActiveWorkbook.Sheets(left(filterArr(i), 31))
             If err.Number = 0 Then 'if sheets already exists:
                tgt.cells.Clear            'clear its content and use it
             Else                           'if not, insert and name it:
                Set tgt = ActiveWorkbook.Sheets.Add(After:=src)
                If Len(filterArr(i)) > 31 Then filterArr(i) = left(filterArr(i), 31)
                tgt.Name = filterArr(i): err.Clear
             End If
            On Error GoTo 0
            filterRange.AutoFilter field:=1, Criteria1:=filterArr(i)
            copyRange.SpecialCells(xlCellTypeVisible).Copy tgt.Range("A1")
        Next i
        src.AutoFilterMode = False
        With Application
            .ScreenUpdating = True
            .EnableEvents = True
            .Calculation = xlCalculationAutomatic
        End With
        MsgBox "Processed " & UBound(filterArr) & "PCP Provider Names..."
    End Sub

上述代码已更新为处理事件工作表(以及事件工作簿上的工作表)。

It needs a little optimization (`ScreenUpdating`, `EnableEvents`, `Calculation`) and check if the sheet with a specific name already exists, clearing all (in such a case) and reuse it, instead of inserting a new one.