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