Question

我有一个主数据表，其中包含一个包含制造商名称的列。数据表包括同一制造商的多个UPC。我需要按制造商创建多个选项卡（不重复），以包含该特定制造商的主表单中的所有信息。我还希望每个标签在该特定表格中重命名为制造商的名称。

诀窍是：我的所有团队成员都必须能够将此文档用作模板，我们都将拥有不同的制造商和UPC。代码需要是一个不使用制造商列表但从文档中的列中提取信息的代码。

谢谢。非常感谢任何帮助。

Answer 1

您应该可以使用此代码进行细微调整。将Column常量更新为制造商列

Sub SplitListIntoWorksheets()
'split list into individual worksheets
Dim lLoop As Long, arrData As Variant
Dim shtData As Worksheet, lgCol As Long, rgSel As range
Dim cUnique As New Collection, shtDest As Worksheet
Const blTitles As Boolean = True                    'true if the data has titles, false otherwise
Const sColumn As String = "A"                       'Which column should the list be split on

application.ScreenUpdating = False
application.Calculation = xlCalculationManual
application.DisplayAlerts = False

lgCol = Cells(1, sColumn).Column
Set rgSel = Cells(1, 1).CurrentRegion

Set shtData = ActiveSheet

With shtData
    'load the column into an array for faster processing
    arrData = .range(.Cells(1, sColumn), .Cells(.Rows.Count, sColumn).End(xlUp)).Value

    'load the array content in a collection, to keep individual values only
    On Error Resume Next

    For lLoop = LBound(arrData, 1) To UBound(arrData, 1)
        cUnique.Add arrData(lLoop, 1), CStr(arrData(lLoop, 1))
    Next

    On Error GoTo 0

    'for each individual value, filter the list, copy the results to a new worksheet
    For lLoop = 1 To cUnique.Count
        .AutoFilterMode = False
        rgSel.CurrentRegion.AutoFilter Field:=lgCol - rgSel.CurrentRegion.Column + 1, Criteria1:=cUnique(lLoop)
        Set shtDest = Sheets.Add
        shtDest.Name = "Data " & cUnique(lLoop)
        rgSel.CurrentRegion.Copy shtDest.Cells(1, 1)
    Next

    .AutoFilterMode = False
End With

application.ScreenUpdating = True 'reenable ScreenUpdating
application.Calculation = xlCalculationAutomatic
application.DisplayAlerts = True
End Sub

VBA - 基于列的多个选项卡，无需复制和重命名选项卡

1 个答案: