按某列分表程序

Sub fenbiao()
Dim sht As Worksheet
Dim i, k, irow As Integer
irow = Sheet1.Range("a65536").End(xlUp).Row

'定位表格最后一行
For i = 2 To irow
k = 0
For Each sht In Sheets
If sht.Name = Sheet1.Range("d" & i) 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)

’把新表格命名为表1的di列的名字
Sheet1.Range("a1").EntireRow.Copy Sheets(Sheets.Count).Range("a1")

‘把a1表的表头复制到新表的表头
Sheet1.Range("d" & i).EntireRow.Copy Sheets(Sheets.Count).Range("a65535").End(xlUp).Offset(1, 0)

’把表1的di行复制到新表里
End If
Next
End Sub