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

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

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

应该创build下面的工作表

 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来保存logging。

^{以下要求在VBE的“工具”，“ 参考”中将引用添加到Microsoft脚本运行时 。}

 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 

通过将所有潜在值批量加载到变体数组中并将它们处理到另一个内存中的对象中，这应该会相当快地处理。 虽然这主要是为了适应你的双列样本而devise的，但我留下了循环中的空间来处理大量的列; 你只需要调整一些硬编码的值。