Ideas to make this code more efficient - vba

Question

I have a worksheet that lists a persons name (column A) with associated data (columns B through G). I have code below that takes this list of a ~ 1000 rows that
A.) First copies and pastes each row three times (to create four identical rows for each entry) then
B.) Loops through the now ~4000 rows and creates a new worksheet for each person.
As there are many duplicate names in column A this only creates ~ ten new worksheets
The thing is, it runs but runs quite slowly (and I receive the Excel not responding warning at times). Is there anything to clean this up to make it more efficient? And after this I run another macro to save the new worksheets to a new workbook. Would it be faster to do that with code here?
Sub Split_Data()
'This will split the data in column A out by unique values
Const NameCol = "A"
Const HeaderRow = 1
Const FirstRow = 2
Dim SrcSheet As Worksheet
Dim TrgSheet As Worksheet
Dim SrcRow As Long
Dim LastRow As Long
Dim TrgRow As Long
Dim person As String
Dim lRow As Long
Dim RepeatFactor As Variant
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Add four rows
lRow = 2
Do While (Cells(lRow, "B") <> "")
RepeatFactor = 4
Range(Cells(lRow, "A"), Cells(lRow, "G")).Copy
Range(Cells(lRow + 1, "A"), Cells(lRow + RepeatFactor - 1, "G")).Select
Selection.Insert Shift:=xlDown
lRow = lRow + RepeatFactor - 1
lRow = lRow + 1
Loop
Set SrcSheet = ActiveSheet
LastRow = SrcSheet.Cells(SrcSheet.Rows.Count, NameCol).End(xlUp).Row
For SrcRow = FirstRow To LastRow
person = SrcSheet.Cells(SrcRow, NameCol).Value
Set TrgSheet = Nothing
On Error Resume Next
Set TrgSheet = Worksheets(person)
On Error GoTo 0
If TrgSheet Is Nothing Then
Set TrgSheet = Worksheets.Add(After:=Worksheets(Worksheets.Count))
TrgSheet.Name = person
SrcSheet.Rows(HeaderRow).Copy Destination:=TrgSheet.Rows(HeaderRow)
End If
TrgRow = TrgSheet.Cells(TrgSheet.Rows.Count, NameCol).End(xlUp).Row + 1
SrcSheet.Rows(SrcRow).Copy Destination:=TrgSheet.Rows(TrgRow)
Next SrcRow
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

Answer 1

first you read the column of names in one pass and put it in an VBA array:
Dim DATA()
with SrcSheet
DATA= .range(.cells(FirstRow, NameCol), .cells(lastRow, namecol)).value2
end with
this gives you a 2D array.
then you create a new scripiting.dictionary , wich fills on a for loop with DATA, and each time a name doesn't exist, you add it to the dictionary.
Dim Dict as new scripting.dictionary 'needs a reference in VBE to : Microsoft Scripting Runtime
dim i& 'long
dim h$ 'string
for i=1 to lastrow-firstrow+1
h=DATA(i,1)
if not dict.exists(h) then
dict(h)=i 'creaates an entry with key=h, item=whatever , here i
end if
next i
You can either create the new worksheets on the fly while adding entries to Dict, or loop later for i=1 to dict.count ...
at the end , you reset all : erase DATA : set Dict=nothing.
Note that this code does not need error handling.
Plz comment on how much time this version needs to do the same task now.
EDIT : your do while looks slow (copy select, insert). If possible B.value2=A.value2 from a range perspective.