为每个唯一值创建新工作表

Question

我有以下代码，可以很好地将相关数据复制到我的工作表中。我为J列中的每个唯一部门手动创建每个工作表，然后运行此宏。我想要一个基于J列中的唯一值动态创建工作表的宏。我在网上找到了很好的资源，但当它到达已经为其创建了工作表的行时，我发现的资源似乎会出错。在手动创建其他工作表之前，我包含了我当前使用的代码以及我的清单表的屏幕截图

Sub CopyRows()

Dim bottomJ As Integer
bottomJ = Range("J" & Rows.Count).End(xlUp).Row
Dim c As Range
Dim ws As Worksheet
For Each c In Sheets("All Dept.").Range("J2:J" & bottomJ)
    For Each ws In Sheets
        ws.Activate
        If ws.Name = c Then
            c.EntireRow.Copy Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
            End If
        Next ws
    Next c

End Sub

Answer 1

• 您的想法存在问题，例如，您使用Hafiz Sb的创建工作表过程来创建工作表，然后使用复制行过程来写入数据。现在，您将更多数据添加到主工作表中，您将陷入困境。如何将新数据添加到相应的工作表中
• 以下假设您只从主工作表中添加数据，而不是删除数据
• 只要列（“scCol”）中有唯一值，它就会复制主工作表无数次，并且通过使用自动筛选，会删除每个工作表上不需要的数据（这是我的想法，但Cyril在评论中提出了类似的建议（如果不相同的话）
• 我在这里也做了类似的事情，将工作表写在单独的工作簿中

Option Explicit

Sub CriteriaWorksheetsCreator()
    ' Accompanying procedures:
    '   ArrUniqueColumnRange
    '   DeleteWorksheetsViaArray
    
    Const sName As String = "All Dept."
    Const sFirst As String = "A1"
    Const sfRow As Long = 1 ' Header Row
    Const scCol As Long = 10 ' Criteria Column
    
    Dim wb As Workbook: Set wb = ThisWorkbook
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    Dim rg As Range: Set rg = sws.Range(sFirst).CurrentRegion
    If rg.Rows.Count = 1 Then Exit Sub ' only one (header) row
    If rg.Columns.Count < scCol Then Exit Sub ' too few columns
    Dim strg As Range
    Set strg = rg.Resize(rg.Rows.Count - sfRow + 1).Offset(sfRow - 1)
    Dim sdrg As Range: Set sdrg = strg.Resize(strg.Rows.Count - 1).Offset(1)
    Dim scrg As Range: Set scrg = sdrg.Columns(scCol)
    
    Dim wsNames As Variant: wsNames = ArrUniqueColumnRange(scrg)
    If IsEmpty(wsNames) Then Exit Sub ' no valid data in 'scrg'
    
    Dim tAddress As String: tAddress = strg.Address
    Dim cAddress As String: cAddress = scrg.Address

    Application.ScreenUpdating = False
    
    DeleteWorksheetsViaArray wb, wsNames
    
    Dim dws As Worksheet
    Dim dtrg As Range
    Dim dcrg As Range
    Dim drg As Range
    Dim n As Long
    Dim dName As String
    For n = 0 To UBound(wsNames)
        sws.Copy After:=wb.Sheets(wb.Sheets.Count)
        Set dws = ActiveSheet
        dName = wsNames(n)
        dws.Name = dName
        Set dtrg = dws.Range(tAddress)
        dtrg.AutoFilter scCol, "<>" & dName
        If Application.Subtotal(103, dtrg.Columns(scCol)) > 1 Then
            Set dcrg = dws.Range(cAddress)
            Set drg = dcrg.SpecialCells(xlCellTypeVisible).EntireRow
            drg.Delete
        End If
        dws.AutoFilterMode = False
    Next n

    sws.Activate
    'wb.Save
    
    Application.ScreenUpdating = True

    MsgBox "Criteria worksheets created.", _
        vbInformation, "Criteria Worksheets Creator"

End Sub


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns the unique values from the first column of a range,
'               in an array.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function ArrUniqueColumnRange( _
    ByVal rg As Range) _
As Variant
    If rg Is Nothing Then Exit Function
    
    Dim Data As Variant
    Dim rCount As Long
    
    With rg.Columns(1)
        rCount = .Rows.Count
        If rCount = 1 Then
            ReDim Data(1 To 1, 1 To 1): Data(1, 1) = .Value
        Else
            Data = .Value
        End If
    End With
    
    With CreateObject("Scripting.Dictionary")
        .CompareMode = vbTextCompare
        Dim Key As Variant
        Dim r As Long
        For r = 1 To rCount
            Key = Data(r, 1)
            If Not IsError(Key) Then
                If Len(Key) > 0 Then
                    .Item(Key) = Empty
                End If
            End If
        Next r
        If .Count = 0 Then Exit Function ' only error values and/or blanks
        ArrUniqueColumnRange = .keys
    End With

End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Deletes all worksheets whose names are in an array ('wsNames'),
'               from a workbook ('wb').
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub DeleteWorksheetsViaArray( _
        ByVal wb As Workbook, _
        ByVal wsNames As Variant)
    On Error GoTo ClearError
    
    If wb Is Nothing Then Exit Sub
    
    Dim LB As Long: LB = LBound(wsNames)
    Dim UB As Long: UB = UBound(wsNames)
    Dim wsnCount As Long: wsnCount = UB - LB + 1
    
    Dim DeleteSheetNames() As String: ReDim DeleteSheetNames(0 To wsnCount - 1)
    
    Dim dn As Long
    
    Dim ws As Worksheet
    Dim sn As Long
    Dim wsName As String
    For sn = LB To UB
        wsName = wsNames(sn)
        On Error Resume Next
        Set ws = wb.Worksheets(wsName)
        On Error GoTo ClearError
        If Not ws Is Nothing Then
            If ws.Visible = xlSheetVeryHidden Then
                ws.Visible = xlSheetVisible
            End If
            DeleteSheetNames(dn) = wsName
            dn = dn + 1
            Set ws = Nothing
        End If
    Next sn
    
    If dn = 0 Then Exit Sub
    
    If dn < wsnCount Then
        ReDim Preserve DeleteSheetNames(0 To dn - 1)
    End If
    
    Application.DisplayAlerts = False
    wb.Worksheets(DeleteSheetNames).Delete
    Application.DisplayAlerts = True
        
ProcExit:
    Exit Sub
ClearError:
    Debug.Print "Run-time error '" & Err.Number & "': " & Err.Description
    Resume ProcExit
End Sub

Answer 2

试试这个。

Sub CreateSheets()

Dim rng As Range
Dim cl As Range
Dim dic As Object
Dim ky As Variant

    Set dic = CreateObject("Scripting.Dictionary")
    
    With Sheets("Sheet1")
        Set rng = .Range(.Range("J2"), .Range("J" & .Rows.Count).End(xlUp))
    End With
    
    For Each cl In rng
        If Not dic.exists(cl.Value) Then
            dic.Add cl.Value, cl.Value
        End If
    Next cl
    
    For Each ky In dic.keys
          Sheets.Add(After:=Sheets(Sheets.Count)).Name = dic(ky)
    Next ky
    
End Sub