Question

I have a large data set with an identifier attributed to each row. There around 10 different identifiers for the whole dataset but this can be variable. The aim is to break the main dataset up into individual worksheets for each group of identifiers. I have written this code below which does the job but seems very clunky with a loop to make all the worksheets and another to go through each row.

    ...

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

    ...

Is there a more efficient way of completing this process instead of looping multiple times?

I also noticed that with this line c.entirerow.copy it is not possible to use a cut instead of copy, what’s the reason for this?

Format is like this:

Answer 1

if I can read well, the original main table would look something like this in a simplified form:

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 

You want to create a new sheet for each of the Areacodes (named Area1,2,3) and fill in the headers + corresponding line.
The code written below is merely a framework on the table form that I have drawn, you can customize this code the way you want it.

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