筛选范围复制粘贴值并创建新工作表

Question

我一直在尝试找到一种使用特定列数据创建多个 sheet 的方法。

如果 Col"A" 有多个重复条目，则过滤单个值使用该值名称创建新的 sheet，复制所有数据并粘贴到新添加的 sheet.

我无法用语言详细说明这件事，很抱歉我的英语不好，我附上了一个示例工作簿。

其中 Sheet1 具有使用列 A 代码的数据将创建多个 sheet。非常感谢您的帮助。

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

数据Sheet

抄送新Sheet

DD新Sheet

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

以上代码已更新以处理活动 sheet（以及活动工作簿上的 sheet）。

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.

Answer 2

这里发生了很多事情：

您希望 sheet 以 A 列中的重复值命名。首先，您需要唯一值，您可以使用 Unique 函数找到这些值：https://support.microsoft.com/en-us/office/unique-function-c5ab87fd-30a3-4ce9-9d1a-40204fb85e1e
您需要将这些值传递到数组中，然后遍历每个值：https://www.automateexcel.com/vba/loop-through-array/
然后您需要复制值并粘贴到每个新的 sheet，这可以通过自动过滤器和使用范围来完成。
那么您需要对添加或删除的 sheet 进行大量错误处理。

试试这个解决方案：

Sub CopyPartOfFilteredRange()
    Application.ScreenUpdating = False
    
    Dim i As Long
    Dim LastRow As Long
    Dim UValues As Variant
    Dim myrange As Range
    Dim sht As Worksheet
    Dim list As New Collection
    
    
    Set sht = ThisWorkbook.Sheets(1)
    On Error Resume Next
    LastRow = sht.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
        If LastRow = 0 Then
            MsgBox "Worksheet contains no data"
                Application.ScreenUpdating = True
                End
        End If
    On Error GoTo 0
    
    Set myrange = sht.Range("A2:A" & LastRow)
    
    On Error Resume Next
        
        For Each Value In myrange
           list.Add CStr(Value), CStr(Value) 'extract unique strings
        Next
    On Error GoTo 0
        ReDim UValues(list.Count - 1, 0)
        
        For i = 0 To list.Count - 1
            UValues(i, 0) = list(i + 1)
        Next
    
    For i = LBound(UValues) To UBound(UValues)
        If Len(UValues(i, 0)) = 0 Then
            GoTo Nexti
        Else
            On Error Resume Next
                ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)).Name = UValues(i, 0)
                    If Err.Number = "1004" Then
                        On Error GoTo 0
                                Application.DisplayAlerts = False
                                    MsgBox "Worksheet name " & UValues(i, 0) & " already taken"
                                        ActiveSheet.Delete
                                Application.DisplayAlerts = True
                               
                        GoTo Nexti
                    Else
            On Error GoTo 0
                            sht.AutoFilterMode = False
                            sht.UsedRange.AutoFilter Field:=1, Criteria1:=UValues(i, 0), VisibleDropDown:=False, Operator:=xlFilterValues
                            sht.UsedRange.SpecialCells(xlCellTypeVisible).Copy
                             With ThisWorkbook.Sheets(UValues(i, 0))
                                .Range("A1").PasteSpecial ''Set this to appropriate sheet number
                             End With
                        Application.CutCopyMode = False
                    End If
        End If
Nexti:
    Next i
sht.AutoFilterMode = False
Application.ScreenUpdating = True
End Sub

Answer 3

创造独一无二的作品sheets

这将删除每个可能存在的 sheet，然后再添加新作品sheet 并将过滤后的数据复制到其中。
如果作品sheet名称超过 31 个字符的限制，其名称将被截断。
如果作品sheet名称无效，将不会重命名。

解决方案

Option Explicit

Sub CopyUniqueWorksheets()
    
    Const ProcTitle As String = "Copy Unique Worksheets"
    
    Dim dTime As Double: dTime = Timer ' time measuring
    Debug.Print "Started '" & ProcTitle & "' at '" & Now & "'." ' log
    
    Const swsName As String = "Sheet1"
    Const sCol As Long = 1
    Const dFirstCellAddress As String = "A1"
    
    Dim wb As Workbook: Set wb = ThisWorkbook
    
    Dim sws As Worksheet: Set sws = wb.Worksheets(swsName)
    If sws.AutoFilterMode Then sws.AutoFilterMode = False
    
    Dim srg As Range: Set srg = sws.Range("A1").CurrentRegion ' Source Range
    Dim srCount As Long: srCount = srg.Rows.Count ' Source Rows Count
    
    If srCount < 2 Then Exit Sub ' just headers or no data at all
    Dim sData As Variant: sData = srg.Columns(sCol).Value
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
    
    Dim dKey As Variant
    Dim dString As String
    Dim r As Long
    
    ' Write the unique strings to a dictionary.
    For r = 2 To srCount
        dKey = sData(r, 1)
        If Not IsError(dKey) Then
            If Len(dKey) > 0 Then
                dString = CStr(dKey)
                If StrComp(dString, swsName, vbTextCompare) <> 0 Then
                    dict(dString) = Empty
                End If
            End If
        End If
    Next r
    If dict.Count = 0 Then Exit Sub ' only blanks and error values and whatnot
    Erase sData
     
    Application.ScreenUpdating = False
    
    Dim scrg As Range ' Source Copy Range
    
    Dim dws As Object
    Dim dwsName As String
    
    For Each dKey In dict.Keys
        ' Restrict to maximum allowed characters (31).
        dwsName = dKey
        If Len(dwsName) > 31 Then
            dwsName = Left(dwsName, 31)
            Debug.Print "'" & dKey & "' is too long." & vbLf _
                & "'" & dwsName & "' is used in the continuation." ' log
        End If
        ' Delete possibly existing sheet.
        On Error Resume Next
            Set dws = wb.Sheets(dwsName)
        On Error GoTo 0
        If Not dws Is Nothing Then ' destination sheet exists
            Application.DisplayAlerts = False
            dws.Delete
            Application.DisplayAlerts = True
        'Else ' destination sheet doesn't exist
        End If
        ' Create a reference to a newly added (destination) worksheet.
        Set dws = wb.Worksheets.Add(After:=wb.Sheets(wb.Sheets.Count))
        ' Rename Destination Worksheet.
        On Error Resume Next
            dws.Name = dwsName
            If Err.Number <> 0 Then ' invalid sheet name
                ' log
                Debug.Print "'" & dwsName & "' cannot be used as a sheet name."
            'Else ' valid sheet name
            End If
        On Error GoTo 0
        ' Create a reference to the Source Copy Range.
        srg.AutoFilter sCol, dKey
        Set scrg = srg.SpecialCells(xlCellTypeVisible) ' headers are visible
        sws.AutoFilterMode = False
        ' Copy the Source Copy Range to the Destination Worksheet.
        scrg.Copy dws.Range(dFirstCellAddress)
        ' Initialize Destination Worksheet variable (reference).
        Set dws = Nothing
    Next dKey
        
    sws.Activate
        
    Application.ScreenUpdating = True
    
Debug.Print "It took " & Timer - dTime & " seconds." ' time measuring
Debug.Print "Ended '" & ProcTitle & "' at '" & Now & "'." ' log
    
    MsgBox "Unique worksheets created.", vbInformation, ProcTitle

End Sub

勉强相关

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      In a workbook ('wb'), deletes all sheets except the ones
'               whose names are in a list ('ExceptionsList').
' Remarks:      At least one of the remaining sheets has to be visible.
'               A very hidden sheet cannot be deleted.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub DeleteSheets()
    On Error GoTo ClearError
    
    Const ExceptionsList As String = "Sheet1"
    Const Delimiter As String = "," ' tied to 'ExceptionsList'
    
    Dim wb As Workbook: Set wb = ActiveWorkbook
    
    Dim Exceptions() As String: Exceptions = Split(ExceptionsList, Delimiter)
    
    Dim sh As Object
    
    Dim ex As Long
    Dim IsFoundVisibleSheet
    For ex = 0 To UBound(Exceptions)
        On Error Resume Next
        Set sh = Nothing
        Set sh = wb.Sheets(Exceptions(ex))
        On Error GoTo ClearError
        If Not sh Is Nothing Then ' sheet exists
            If sh.Visible = xlSheetVisible Then ' sheet is visible
                IsFoundVisibleSheet = True
                Exit For
            'Else ' sheet is not visible
            End If
        'Else ' sheet doesn't exist
        End If
    Next ex
    If Not IsFoundVisibleSheet Then Exit Sub ' no remaining visible sheets
    
    Dim SheetNames() As String: ReDim SheetNames(1 To wb.Sheets.Count)
    Dim VeryHidden() As String: ReDim VeryHidden(1 To wb.Sheets.Count)
    
    Dim sn As Long
    Dim vh As Long
    
    Dim shName As String
    For Each sh In wb.Sheets
        shName = sh.Name
        If IsError(Application.Match(shName, Exceptions, 0)) Then
            sn = sn + 1
            SheetNames(sn) = shName
            If sh.Visible = xlVeryHidden Then
                vh = vh + 1
                VeryHidden(vh) = shName
            'Else ' sheet is not very hidden
            End If
        'Else ' sheet found in 'Exceptions'
        End If
    Next sh
    
    If sn = 0 Then Exit Sub ' no sheets to delete
    ReDim Preserve SheetNames(1 To sn)
    
    If vh > 0 Then
        ReDim Preserve VeryHidden(1 To vh)
        For vh = 1 To vh
            wb.Sheets(VeryHidden(vh)).Visible = xlSheetVisible
        Next vh
    'Else ' no very hidden sheets
    End If
    
    Application.DisplayAlerts = False ' delete without confirmation
    wb.Sheets(SheetNames).Delete
    Application.DisplayAlerts = True

ProcExit:
    Exit Sub
ClearError:
    Debug.Print "Run-time error '" & Err.Number & "': " & Err.Description
    Resume ProcExit
End Sub

初始（旧）答案

这个想法是正确的，但它需要永远在 OP 的数据上。
这将在复制源作品sheet 并重命名之前删除每个可能存在的 sheet。然后它将过滤它以删除复制作品sheet.
中table范围内不需要的行（不是整行）

Option Explicit

Sub CopyUniqueWorksheets()
    
    Const swsName As String = "Sheet1"
    Const sCol As Long = 1
    
    Dim wb As Workbook: Set wb = ThisWorkbook
    
    Dim sws As Worksheet: Set sws = wb.Worksheets(swsName)
    If sws.AutoFilterMode Then sws.AutoFilterMode = False
    
    Dim srg As Range: Set srg = sws.Range("A1").CurrentRegion ' Table Range
    Dim scrg As Range: Set scrg = srg.Columns(sCol) ' Column Range
    Dim srCount As Long: srCount = scrg.Rows.Count
    Dim dcrgAddress As String: dcrgAddress = scrg.Address(0, 0)
    Dim sdrg As Range: Set sdrg = srg.Resize(srCount - 1).Offset(1) ' Data Range
    Dim ddrgAddress As String: ddrgAddress = sdrg.Address(0, 0)
    
    If srCount < 2 Then Exit Sub ' just headers or no data at all
    Dim sData As Variant: sData = scrg.Value
    
    Dim drgAddress As String: drgAddress = srg.Address(0, 0)
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
    
    Dim dKey As Variant
    Dim dString As String
    Dim r As Long
    
    For r = 2 To srCount
        dKey = sData(r, 1)
        If Not IsError(dKey) Then
            If Len(dKey) > 0 Then
                dString = CStr(dKey)
                If StrComp(dString, swsName, vbTextCompare) <> 0 Then
                    dict(dString) = Empty
                End If
            End If
        End If
    Next r
    
    Application.ScreenUpdating = False
    
    Dim dws As Object
    Dim drg As Range ' Delete Range
    Dim dcrg As Range ' Column Range
    Dim ddrg As Range ' Data Range
    
    For Each dKey In dict.Keys
        ' Delete possibly existing sheet.
        On Error Resume Next
            Set dws = wb.Sheets(dKey)
        On Error GoTo 0
        If Not dws Is Nothing Then ' destination sheet exists
            Application.DisplayAlerts = False
            dws.Delete
            Application.DisplayAlerts = True
        'Else ' destination sheet doesn't exist
        End If
        ' Copy source worksheet.
        sws.Copy After:=wb.Sheets(wb.Sheets.Count)
        Set dws = ActiveSheet
        ' Rename destination worksheet.
        On Error Resume Next
            dws.Name = dKey
            If Err.Number <> 0 Then
                MsgBox "'" & dKey & "' is an invalid sheet name.", vbExclamation
            End If
        On Error GoTo 0
        ' Delete rows.
        Set dcrg = dws.Range(dcrgAddress)
        Set ddrg = dws.Range(ddrgAddress)
        dcrg.AutoFilter 1, "<>" & dKey
        On Error Resume Next
            Set drg = ddrg.SpecialCells(xlCellTypeVisible)
        On Error GoTo 0
        dws.AutoFilterMode = False ' to not delete entire rows
        If Not drg Is Nothing Then
            drg.Delete xlShiftUp
            Set drg = Nothing
        End If
        Set dws = Nothing
    Next dKey
        
    sws.Activate
        
    Application.ScreenUpdating = True
    
    MsgBox "Unique worksheets created.", vbInformation

End Sub

筛选范围复制粘贴值并创建新工作表

Filter Range Copy Paste the Value and Create new Sheets

excel

vba

autofilter

创造独一无二的作品sheets