Romper el set de datos en hojas de trabajo individuales por identificador

Tengo un gran set de datos con un identificador atribuido a cada fila. Hay alnetworkingedor de 10 identificadores diferentes para todo el set de datos, pero esto puede ser variable. El objective es dividir el set de datos principal en hojas de trabajo individuales para cada grupo de identificadores. He escrito este código a continuación, que hace el trabajo, pero parece muy torpe con un bucle para hacer todas las hojas de trabajo y otro para recorrer cada fila.

... '--> Get list of Area Codes ws1.Range("N:N").Copy Set TempWS = Sheets.Add With TempWS With .Range("A:A") .PasteSpecial .AdvancedFilter xlFilterInPlace, Unique:=True .SpecialCells(xlCellTypeVisible).Copy End With .Range("B:B").PasteSpecial .ShowAllData .Range("A:A").Delete .Rows(1).Delete tmpLR = .Range("A" & Rows.Count).End(xlUp).Row + 1 End With '--> Create Worksheet for Each Code i = 1 Do Until i = tmpLR Set ws = Sheets.Add ws.Name = TempWS.Cells(i, 1).Text ws1.Range("A1").EntireRow.Copy ws.Rows("1:1").PasteSpecial i = i + 1 Loop TempWS.Delete '--> Break Up Main Data Sheet into Area Code Sheets Set rng = ws1.Range("N2:N" & LRws1) For Each c In rng shname = c.Text c.EntireRow.Copy Set oWS = Sheets(shname) oLR = oWS.Range("A" & Rows.Count).End(xlUp).Row + 1 oWS.Rows(oLR).PasteSpecial Next ... 

¿Hay una manera más eficiente de completar este process en lugar de repetir varias veces?

También noté que con esta línea c.entirerow.copy no es posible usar un cut lugar de copy , ¿cuál es el motivo?

El formatting es así:

enter image description here

si puedo leer bien, la tabla principal original se vería así en una forma simplificada:

 HEADER1 HEADER2 HEADER3 AREACODES Area1_Value1 Area1_Value2 Area1_Value3 Area1 Area2_Value1 Area2_Value2 Area2_Value3 Area2 Area3_Value1 Area3_Value2 Area3_Value3 Area3 

Desea crear una hoja nueva para cada uno de los códigos de área (denominada Área1,2,3) y completar los encabezados + línea correspondiente.
El código escrito a continuación es simplemente un marco en la tabla que he dibujado, puede personalizar este código de la forma que desee.

 Sub Area_Codes() Dim oRange As Range Dim oRange_Headers As Range Dim vArray_Headers As Variant Dim oRange_Area As Range Dim vArray_Area As Variant Dim oRange_Area_Dest As Range Dim lRange_Rows As Long Dim iRange_Cols As Integer Dim vArray As Variant Dim oSheet_Main As Excel.Worksheet Dim oSheet As Excel.Worksheet Dim lUse_Row As Long Dim lCnt As Long Dim lCnt_B As Long Dim bExists As Boolean Const AreaCodes_Col = 4 Set oSheet_Main = ThisWorkbook.Sheets(1) Set oRange = oSheet_Main.UsedRange lRange_Rows = oRange.Rows.Count iRange_Cols = oRange.Columns.Count ReDim vArray(1 To lRange_Rows, 1 To iRange_Cols) vArray = oRange 'load your headers into a separate range Set oRange_Headers = oRange.Rows(1) 'Set dimensions of the array equal to dimensions of the range and load range into memory (array) ReDim vArray_Headers(1 To 1, 1 To iRange_Cols) vArray_Headers = oRange 'Clear the range from memory Set oRange_Headers = Nothing 'Start as from row 2 (Row 1 = header) For lCnt = 2 To lRange_Rows 'Clear the row containing the area code info from memory - reload on every loop Set oRange_Area = Nothing 'Exceptional activate oSheet_Main.Activate 'Set row of Area + load into memory Set oRange_Area = oSheet_Main.Range(Cells(lCnt, 1), Cells(lCnt, iRange_Cols)) ReDim vArray_Area(1 To 1, 1 To iRange_Cols) vArray_Area = oRange_Area 'Check if sheet exists, load result into boolean value bExists = False For Each oSheet In ThisWorkbook.Sheets If oSheet.Name = vArray(lCnt, AreaCodes_Col) Then bExists = True End If Next oSheet 'Add sheet if sheet doesn't exist + name Set oSheet = Nothing If Not bExists Then Set oSheet = Sheets.Add oSheet.Name = (vArray(lCnt, AreaCodes_Col)) Else 'Define sheet object if sheet already exists Set oSheet = ThisWorkbook.Sheets(vArray(lCnt, AreaCodes_Col)) oSheet.Activate End If 'Define destination range of headers; You could name this otherwise, to avoid confusion Set oRange_Headers = oSheet.Range(Cells(1, 1), Cells(1, iRange_Cols)) oRange_Headers = vArray_Headers 'Check last row used, +1 sets the last row + 1 -> the destination row lUse_Row = oSheet.UsedRange.Rows.Count + 1 Set oRange_Area_Dest = oSheet.Range(Cells(lUse_Row, 1), Cells(lUse_Row, iRange_Cols)) 'Fill in the destination row oRange_Area_Dest = vArray_Area Next lCnt End Sub