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

End Sub

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

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

1 个答案: