将重复值移动到新工作表中答案

【问题标题】：move duplicated values into new sheets将重复值移动到新工作表中
【发布时间】：2016-01-18 05:53:05
【问题描述】：

我正在尝试复制“位置 ID”列中的重复值并将相同的重复项复制到新工作表中，并使用 VBA 将该工作表命名为重复值。我一直在搞乱，我得到的最接近的是创建一个提取所有重复值的列表。你能帮我解决这个问题吗？例如

------ 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

【问题讨论】：

这个问题有很多答案。一位HERE
只查找重复项：
Sub sbFindDuplicatesInColumn() Dim lastRow As Long Dim matchFoundIndex As Long Dim iCntr As Long lastRow = Range("B65000").End(xlUp).Row For iCntr = 1 To lastRow If Cells(iCntr, 2) "" Then matchFoundIndex = WorksheetFunction.Match(Cells(iCntr, 2), Range("B1:B" & lastRow), 0) If iCntr matchFoundIndex Then Cells(iCntr, 4) = "Duplicate" End If End If Next End Sub

标签： excel vba

【解决方案1】：

您可以将唯一的位置 ID 拆分为 Scripting.Dictionary 对象的 Keys，同时使用字典的 Items 来保存记录。

^{以下需要在 VBE 的工具中添加对 Microsoft Scripting Runtime 的引用，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

通过将所有潜在值批量加载到变量数组中并将它们处理到另一个内存对象中，这应该会很快处理。虽然这主要是为容纳您的两列样本而设计的，但我在循环中留出了空间来处理更多的列；您只需要调整一些硬编码值。

【讨论】：