如何基于数组中的值命名新工作表并从原始数据集中复制相关值？

Question

我在P，Q，R列中有数据。 我想筛选R，并为R列中的每个唯一项创建一个新的工作表。此新工作表还将带入P和Q中的关联值。

到目前为止，我已经学习了如何在R中过滤数据并将唯一值放入数组中。 对于数组中的每个值，我制作了一个名为Array1（i）的新表，因为由于某种原因我无法将该值转换为字符串。 如何以一种优化的方式执行此操作，以便为R中的每个唯一值创建一个新工作表，并在P和Q中的相同行中引入这些值？ 这是我的代码：

另外，如何动态声明数组而不是硬编码50？ 如何为列R使用动态范围？

请注意，数组中的值将类似于6X985

Sub testarray()
Dim TestRg As Excel.Range
Dim Array1(50) As Variant
Dim SheetName As String
Dim i, j, k As Integer
i = 1

Set TestRg = Range("R1:R36879")
TestRg.AdvancedFilter Action:=xlFilterInPlace, Unique:=True
For Each c In TestRg.SpecialCells(xlCellTypeVisible)
    Array1(i) = c.Value
    'SheetName = CStr(c.Value)
   Worksheets.Add.Name = i
    i = i + 1
Next c
j = i - 1
i = 1

Worksheets("Sheet1").ShowAllData
For Each c In Range("S3:S" & j)
    c.Value = Array1(i)
    i = i + 1

Next c
k = 1
For Each d In Range("T3:T" & j)
        d.Value = k
        k = k + 1
        Next d

结束子

Answer 1

代码本身是高级的，我添加了注释以帮助理解。 希望对您有所帮助：

Sub tgr()

    Dim wsData As Worksheet
    Dim wsNew As Worksheet
    Dim rngData As Range
    Dim xlCalc As XlCalculation
    Dim arrUnq() As Variant
    Dim strSheetName As String
    Dim UnqIndex As Long
    Dim i As Long

    Set wsData = Sheets("Sheet1")
    Set rngData = wsData.Range("R1", wsData.Cells(Rows.Count, "R").End(xlUp))

    'Disable application items to let code run faster
    With Application
        xlCalc = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
        .DisplayAlerts = False
    End With

    'Re-enable all the application items just in case there's an error
    On Error GoTo CleanExit

    'Get the list of unique values from rngData, sorted alphabetically
    'Put that list into the arrUnq array
    With Sheets.Add
        rngData.AdvancedFilter xlFilterCopy, , .Range("A1"), True
        .UsedRange.Sort .UsedRange, xlAscending, Header:=xlYes
        arrUnq = Application.Transpose(.Range("A2", .Cells(Rows.Count, "A").End(xlUp)).Value)
        .Delete
    End With

    For UnqIndex = LBound(arrUnq) To UBound(arrUnq)

        'Verify a valid worksheet name
        strSheetName = arrUnq(UnqIndex)
        For i = 1 To 7
            strSheetName = Replace(strSheetName, Mid(":\/?*[]", i, 1), " ")
        Next i
        strSheetName = Trim(Left(WorksheetFunction.Trim(strSheetName), 31))

        'Check if worksheet name already exists
        If Not Evaluate("ISREF('" & strSheetName & "'!A1)") Then
            'Sheet doesn't already exist, create sheet
            Sheets.Add(After:=Sheets(Sheets.Count)).Name = strSheetName
        End If
        Set wsNew = Sheets(strSheetName)
        wsNew.UsedRange.Clear

        'Filter for the unique data
        With rngData
            .AutoFilter 1, arrUnq(UnqIndex)

            'Copy the data from columns P:R to the new sheet
            Intersect(wsData.Range("P:R"), .EntireRow).SpecialCells(xlCellTypeVisible).Copy wsNew.Range("A1")
        End With

    Next UnqIndex

    rngData.AutoFilter  'Remove any remaining filters

CleanExit:
    With Application
        .Calculation = xlCalc
        .ScreenUpdating = True
        .EnableEvents = True
        .DisplayAlerts = True
    End With

    If Err.Number <> 0 Then
        MsgBox Err.Description, , "Error: " & Err.Number
        Err.Clear
    End If

End Sub