VBA - 基於列的多個選項卡，無需複製和重命名選項卡

Question

我有一個主數據表，其中包含一個包含製造商名稱的列。數據表包含同一製造商提供的多個UPC。我需要由製造商創建多個選項卡（無需重複），以包含來自該特定製造商的主工作表的所有信息。我還希望每個製表符都在該特定表單中更名爲製造商的名稱。

訣竅是：我所有的團隊成員必須能夠將此文檔用作模板，我們都將擁有不同的製造商和UPC。該代碼必須是不使用製造商的集合列表的，但是從文檔中的列中提取信息。

謝謝。任何幫助深表感謝。

Answer 1

您應該可以稍微調整使用此代碼。更新sColumn常數到您的製造商專欄

Sub SplitListIntoWorksheets() 
'split list into individual worksheets 
Dim lLoop As Long, arrData As Variant 
Dim shtData As Worksheet, lgCol As Long, rgSel As range 
Dim cUnique As New Collection, shtDest As Worksheet 
Const blTitles As Boolean = True     'true if the data has titles, false otherwise 
Const sColumn As String = "A"      'Which column should the list be split on 

application.ScreenUpdating = False 
application.Calculation = xlCalculationManual 
application.DisplayAlerts = False 

lgCol = Cells(1, sColumn).Column 
Set rgSel = Cells(1, 1).CurrentRegion 

Set shtData = ActiveSheet 

With shtData 
    'load the column into an array for faster processing 
    arrData = .range(.Cells(1, sColumn), .Cells(.Rows.Count, sColumn).End(xlUp)).Value 

    'load the array content in a collection, to keep individual values only 
    On Error Resume Next 

    For lLoop = LBound(arrData, 1) To UBound(arrData, 1) 
     cUnique.Add arrData(lLoop, 1), CStr(arrData(lLoop, 1)) 
    Next 

    On Error GoTo 0 

    'for each individual value, filter the list, copy the results to a new worksheet 
    For lLoop = 1 To cUnique.Count 
     .AutoFilterMode = False 
     rgSel.CurrentRegion.AutoFilter Field:=lgCol - rgSel.CurrentRegion.Column + 1, Criteria1:=cUnique(lLoop) 
     Set shtDest = Sheets.Add 
     shtDest.Name = "Data " & cUnique(lLoop) 
     rgSel.CurrentRegion.Copy shtDest.Cells(1, 1) 
    Next 

    .AutoFilterMode = False 
End With 

application.ScreenUpdating = True 'reenable ScreenUpdating 
application.Calculation = xlCalculationAutomatic 
application.DisplayAlerts = True 
End Sub