将重复的值移动到新的工作表中 [英] move duplicated values into new sheets

问题描述

我正在尝试在位置ID列中复制重复的值，并将相同的重复项复制到新的工作表中，并使用VBA将工作表命名为重复的值。我一直在乱七八糟，我最接近的是创建一个提取所有重复值的列表。你能帮我一下吗例如

I'm trying to copy duplicated values in column "Location ID" and past the same duplicates into a new sheet and name the sheet as the duplicated value using VBA. I have been messing around, and the closest I've gotten is the creation of a list that extracts all duplicate values. Could you please help me with this. e.g.

------ Main worksheet ---------
Machine Name    Location ID
A-1             X
A-2             X
A-3             X
B-11            A
B-12            A
C-7             C
C-8             C

应创建以下工作表

Sheet X
        Machine Name      Location ID
        A-1               X
        A-2               X
        A-3               X

Sheet A
        Machine Name    Location ID
        B-11            A
        B-12            A

Sheet C
        Machine Name    Location ID
        C-7             C
        C-8             C

推荐答案

您可以将唯一的位置ID 分割成 Scripting.Dictionary 对象的键，而使用字典的项目保存记录。

You can split the unique Location IDs into a Scripting.Dictionary object's Keys while using the dictionary's Items to hold the records.

^{以下要求将参考添加到 Microsoft Scripting Runtime 中VBE的工具，参考资料。}

^{The following requires a reference be added to Microsoft Scripting Runtime in the VBE's Tools, References.}

Sub split_Locations_to_Worksheets()
    Dim a As Long, b As Long, c As Long, aLOCs As Variant, aTMP As Variant
    Dim dLOCs As New Scripting.Dictionary

    appTGGL bTGGL:=False

    With Worksheets("Main")
        With .Cells(1, 1).CurrentRegion
            aLOCs = .Cells.Value2
            For a = LBound(aLOCs, 1) + 1 To UBound(aLOCs, 1)
                If dLOCs.Exists(aLOCs(a, 2)) Then
                    ReDim aTMP(1 To UBound(dLOCs.Item(aLOCs(a, 2)), 1) + 1, 1 To UBound(aLOCs, 2))
                    For b = LBound(dLOCs.Item(aLOCs(a, 2)), 1) To UBound(dLOCs.Item(aLOCs(a, 2)), 1)
                        For c = LBound(dLOCs.Item(aLOCs(a, 2)), 2) To UBound(dLOCs.Item(aLOCs(a, 2)), 2)
                            aTMP(b, c) = dLOCs.Item(aLOCs(a, 2))(b, c)
                        Next c
                    Next b
                    For c = LBound(aLOCs, 2) To UBound(aLOCs, 2)
                        aTMP(b, c) = aLOCs(a, c)
                    Next c
                    dLOCs.Item(aLOCs(a, 2)) = aTMP
                Else
                    ReDim aTMP(1 To 2, 1 To UBound(aLOCs, 2))
                    aTMP(1, 1) = aLOCs(1, 1): aTMP(1, 2) = aLOCs(1, 2)
                    aTMP(2, 1) = aLOCs(a, 1): aTMP(2, 2) = aLOCs(a, 2)
                    dLOCs.Add Key:=aLOCs(a, 2), Item:=aTMP
                End If
            Next a

            For Each aLOCs In dLOCs.keys
                On Error GoTo bm_Need_WS
                With Worksheets("Sheet " & aLOCs)
                    .Cells.ClearContents
                    .Cells(1, 1).Resize(UBound(dLOCs.Item(aLOCs), 1), UBound(dLOCs.Item(aLOCs), 2)) = dLOCs.Item(aLOCs)
                End With
            Next aLOCs
        End With
    End With

    GoTo bm_Safe_Exit

bm_Need_WS:
    On Error GoTo 0
    With Worksheets.Add(after:=Sheets(Sheets.Count))
        .Name = "Sheet " & aLOCs
        .Visible = True
        With ActiveWindow
            .SplitColumn = 0
            .SplitRow = 1
            .FreezePanes = True
            .Zoom = 80
        End With
    End With
    Resume

bm_Safe_Exit:
    dLOCs.RemoveAll: Set dLOCs = Nothing
    appTGGL
End Sub

Public Sub appTGGL(Optional bTGGL As Boolean = True)
    Application.ScreenUpdating = bTGGL
    Application.EnableEvents = bTGGL
    Application.DisplayAlerts = bTGGL
    Application.Calculation = IIf(bTGGL, xlCalculationAutomatic, xlCalculationManual)
End Sub

通过批量加载所有潜在值变成一个变体数组并将它们处理成另一个内存中的对象，这应该很快地处理。虽然这主要是为了适应您的两列样品，我已经在循环中留出空间来处理更多的列;你只需要调整一些硬编码的值。

By bulk loading all potential values into a variant array and processing them into another in-memory object, this should process quite quickly. While this is largely designed to accommodate your two-column sample, I've left room in the loops to process larger numbers of columns; you will just have to adjust some of the hard-coded values.

这篇关于将重复的值移动到新的工作表中的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！