將重複值移入新工作表

Question

我試圖將「位置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 

Answer 1

您可以在使用字典的Items持有記錄分裂獨特位置標識爲Scripting.Dictionary對象的Keys。

^{以下需要參考在VBE的工具，References被添加到Microsoft Scripting Runtime。}

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 

通過批量加載所有可能值分到一個變量數組和將它們加工成另一個內存對象，這應該相當迅速地處理。雖然這主要是爲了適應你的雙列樣本而設計的，但我留下了循環中的空間來處理大量的列;你只需要調整一些硬編碼值。