新人请教一个如何复制大量数据的程序

uibedu

Sub copy02()
Dim i As Integer, sht As Worksheet, rng As Range, r As Integer
Set sht = Worksheets("投资项目原始数据")
r = sht.Range("a65536").End(xlUp).Row
For i = 2 To r
On Error Resume Next
If sht.Cells(i, "A").Value = Worksheets(sht.Cells(i, "A").Value).Name Then
Set rng = sht.Cells(i, "A").Resize(1, 24)
rng.Copy Worksheets(sht.Cells(i, "A").Value).Range("A3")
End If
Next
End Sub
目前的问题是一个单位有多个项目，但是只能复制一条项目记录过去，见标红的地方，怎么改为把一个单位所有条数据全部复制到对应的工作表