```
Sub distribute_data()
Dim wsData As Worksheet, ws As Worksheet, LastR As Long
Dim dic As Object, x, y, r As Range, flg As Balloon, i As Long
Set wsData = Sheets("sheet1")
Set dic = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
With wsData
For Each r In .Range("a2", .Range("a65536").End(xlUp))
If r <> "" And Not dic.exists(r.Value) Then
dic.Add r.Value, r.Row
End If
Next
End With
x = dic.keys
y = dic.items
For i = LBound(x) To UBound(x)
flag = False
For Each ws In Sheets
If ws.Name <> "Sheet1" And ws.Name = x(i) Then
flag = True
Exit For
End If
Next
If flag = False Then
Worksheets.Add before:=wsData
ActiveSheet.Name = x(i)
wsData.Rows(1).Copy Destination:=Sheets(x(i)).Rows(1)
If i < UBound(x) Then
wsData.Rows(y(i) & ":" & y(i + 1) - 2).Copy Destination:=Sheets(x(i)).Rows(2)
Else
LastR = wsData.Range("a65536").End(xlUp).Row
wsData.Rows(y(i) & ":" & LastR).Copy Destination:=Sheets(x(i)).Rows(2)
End If
Else
lastR2 = Sheets(x(i)).Range("a65536").End(xlUp).Row
If i < UBound(x) Then
wsData.Rows(y(i) & ":" & y(i + 1) - 2).Copy Destination:=Sheets(x(i)).Rows(2)
Else
LastR = wsData.Range("a65536").End(xlUp).Row
wsData.Rows(y(i) & ":" & LastR).Copy Destination:=Sheets(x(i)).Rows(2)
End If
End If
Next
wsData.Move before:=Sheets(1)
Application.ScreenUpdating = True
Set wsData = Nothing
Set dic = Nothing
Erase x
Erase y
End Sub
```