把数据按列拆分为数据表

Sub caifengbiao()
Dim i, k As Integer
Dim sht As Worksheet

For i = 2 To Range("a65536").End(xlUp).Row
k = 0
For Each sht In Sheets
If Sheet1.Range("d" & i) = sht.Name Then
Sheet1.Range("d" & i).EntireRow.Copy sht.Range("a65536").End(xlUp).Offset(1, 0)
k = 1
End If
Next
If k = 0 Then

Sheets.Add after:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = Sheet1.Range("d" & i)
Sheet1.Range("a1").EntireRow.Copy Sheets(Sheets.Count).Range("a1")
Sheet1.Range("d" & i).EntireRow.Copy Sheets(Sheets.Count).Range("a65536").End(xlUp).Offset(1, 0)

End If

Next

End Sub