Question

我正在尝试将“位置ID”列中的重复值复制并将相同的重复项复制到新工作表中，并使用VBA将工作表命名为重复值。我一直在搞乱，最接近的是创建一个提取所有重复值的列表。你能帮帮我吗？ 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

Answer 1

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

^{以下内容需要在VBE的工具中Microsoft Scripting Runtime添加引用{/ 3}}。}

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

通过将所有潜在值批量加载到变量数组中并将它们处理到另一个内存中对象中，这应该非常快速地处理。虽然这主要是为了适应您的双柱样品，但我在循环中留下了处理大量色谱柱的空间;你只需要调整一些硬编码值。

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

1 个答案: