I've taken the liberty of writing a different sub for the following reasons.
- 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.
- 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.
