EXCEL- Need to split a table to individual sheets depending on cell value without any blanks

Question

I'm trying to split a table into different sheets, relevant to column 1 of my sheet

Main sheet

So say i have a sheet called 109 i want all 109's entries (entire rows of the table copied over)

109 sheet

With Columns and Rows in Red

enter image description here

 Sub populate()

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

Dim lngLastRow As Long

Sheets("Data").Select
Range("D11").Select

' Set NE sheets

Set jc109 = Sheets("109")
Set jj112 = Sheets("112")
Set gd126 = Sheets("126")
Set pw216 = Sheets("216")
Set sa223 = Sheets("223")
Set ms269 = Sheets("269")
Set ad363 = Sheets("363")


lngLastRow = Cells(Rows.Count, "A").End(xlUp).Row


With Range("D11", "P" & lngLastRow)

.AutoFilter

' Copy NE stock info

.AutoFilter Field:=1, Criteria1:="109"
.Copy jc109.Range("D11")
.AutoFilter Field:=1, Criteria1:="112"
.Copy jj112.Range("D11")
.AutoFilter Field:=1, Criteria1:="126"
.Copy gd126.Range("D11")
.AutoFilter Field:=1, Criteria1:="216"
.Copy pw216.Range("D11")
.AutoFilter Field:=1, Criteria1:="223"
.Copy sa223.Range("D11")
.AutoFilter Field:=1, Criteria1:="269"
.Copy ms269.Range("D11")
.AutoFilter Field:=1, Criteria1:="363"
.Copy ad363.Range("D11")

.AutoFilter

End With

Call emailsheets

  Application.ScreenUpdating = True
 .EnableEvents = True
 Application.Calculation = xlCalculationAutomatic

End Sub

If if have a row of .... as entry's then it works but copies over a row of ... at the top, not too much of an issue i pasted it to a hidden row. but then it seem sto throw #REF errors in the cells if i don't have an entry for each engineer number it is searching for.

Answer 1

I've taken the liberty of writing a different sub for the following reasons.

1. As your data set expands, so does the number of times your code has to access the sheet, which could mean a significant reduction in performance. I've used arrays to eliminate this problem all data is read in one go and then processed and then written.
2. In your code you've (inadvertently) used ActiveWorkbook. Usually this doesn't create a problem but may cause issues if you have multiple workbooks open. Active refers to whatever is active, regardless of where your code is. You should have a look at this

Some assumptions that apply

• Sheets for all engineers are already present, if not this will throw an error
• The row "Entry 0" has been removed, my code does not require this row, it can however be adapted to incorporate it if it is required by your document.
• With the "Entry 0" row gone I've assumed the value "112" in column "Eng No." to be in cell D11 and the value "0" in column "Entry" to be in cell C11
• Only values are copied over, the actual values are not.

Here is the code

Option Explicit

Sub populate()

    Dim arrData() As Variant, arrEngData() As Variant
    Dim arrEngNo() As Long
    Dim wsData As Worksheet, wsEng As Worksheet
    Dim i As Long, j As Long, k As Long

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With

    Set wsData = ThisWorkbook.Worksheets("Data")

    'Get all Engineer numbers
    With wsData
        arrData = .Range(.Cells(11, 4), .Cells(11, 4).End(xlDown))                      'I've altered the way the array is collected, instead of looking for the first value in column D from the bottom up, it now looks for the last value in column D going down column D starting at row 11
    End With

    'Get unique engineer numbers
    ReDim arrEngNo(0)                                                                   'I've tweaked the start of the procedure so it does not automatically record the first value it encounters, in case this is a 0
    For i = LBound(arrData, 1) To UBound(arrData, 1)
        If UBound(arrEngNo) = 0 And Not arrData(i, 1) = 0 Then                          'I've added a check to so that no 0 value is entered as an engineer's number
            ReDim arrEngNo(1 To 1)                                                      'If a valid engineer's number is found, resize the array
            arrEngNo(1) = arrData(1, 1)
        Else
            For j = LBound(arrEngNo) To UBound(arrEngNo)
                If arrEngNo(j) = arrData(i, 1) Or arrData(i, 1) = 0 Then                'I've added a check to also skip 0 values besides already recorded engineer's numbers
                    Exit For
                ElseIf j = UBound(arrEngNo) And Not arrEngNo(j) = arrData(i, 1) Then
                    ReDim Preserve arrEngNo(1 To UBound(arrEngNo) + 1)
                    arrEngNo(UBound(arrEngNo)) = arrData(i, 1)
                End If
            Next j
        End If
    Next i

    'Collect all records in array to process
    With wsData
        arrData = .Range(.Cells(11, 4), .Cells(11, 4).End(xlDown).Offset(0, 12))        'I've altered the way the array is collected, instead of looking for the first value encountered from the bottom up in column P, which could be empty and so potentially it could miss records, it now looks down to the last value encounterd in column D (which is the last formula in column D) and then moves over to column P
    End With

    'Iterate through all available engineer numbers
    For i = LBound(arrEngNo) To UBound(arrEngNo)

        'Reset the array for the engineer specific records
        ReDim arrEngData(1 To 13, 0)

        'Iterate through the records and copy the relevant records to engineer specific array
        For j = LBound(arrData, 1) To UBound(arrData, 1)
            'If engineer numbers match, then copy data to engineer specific array
            If arrData(j, 1) = arrEngNo(i) Then
                If UBound(arrEngData, 2) = 0 Then
                    ReDim arrEngData(1 To 13, 1 To 1)
                Else
                    ReDim Preserve arrEngData(1 To 13, 1 To UBound(arrEngData, 2) + 1)
                End If

                'Copy record
                For k = 1 To 13
                    arrEngData(k, UBound(arrEngData, 2)) = arrData(j, k)
                Next k
            End If
        Next j

        'Set the engineer worksheet
        Set wsEng = ThisWorkbook.Worksheets(CStr(arrEngNo(i)))

        'Write collected records to engineer worksheet
        With wsEng
            .Range(.Cells(11, 4), .Cells(11, 4).Offset(UBound(arrEngData, 2) - 1, UBound(arrEngData, 1) - 1)) = Application.Transpose(arrEngData)
        End With
    Next i

    wsData.Activate

    Call emailsheets

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With

End Sub

Performance:

• 10,000 records, 500 unique engineer numbers processed in 1,33837890625 seconds
• 1,000,000 records, 1,000 unique engineer numbers processed in 116,3740234375 seconds

I hope this works for you and creates a starting point from which you can expand your VBA knowledge.