EXCEL vba编程问题

修改后的宏如下：
Sub Macro1()
On Error Resume Next
Dim I As Integer, N As Integer
Dim SR As Integer, ER As Integer, FC As Integer
Dim TS As String, SS As String
Dim OS As Worksheet, NS As Worksheet, KS As Worksheet
Set OS = ActiveSheet
FC = ActiveCell.Column
SR = ActiveCell.Row + 1
ER = ActiveCell.SpecialCells(xlCellTypeLastCell).Row
Application.ScreenUpdating = False
For I = SR To ER
TS = Cells(I, FC)
For Each st In Sheets '修改开始
If st.Name = TS Then
Application.DisplayAlerts = False
Worksheets(TS).Delete
Application.DisplayAlerts = True
End If
Next '修改结束
If WorksheetFunction.CountIf(Range(Cells(SR, FC), Cells(I, FC)), TS) = 1 Then
Set NS = ActiveWorkbook.Worksheets.Add(after:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count))
N = 0
Do
If N Then
SS = TS & "(" & N & ")"
Else
SS = TS
End If
Set KS = Worksheets(SS)
If KS Is Nothing Then
NS.Name = SS
Exit Do
Else
Set KS = Nothing
End If
N = N + 1
Loop
OS.Select
Rows(SR - 1).Select
Selection.AutoFilter
Selection.AutoFilter Field:=FC, Criteria1:=TS
ActiveSheet.UsedRange.SpecialCells(xlCellTypeVisible).Copy
NS.Select
ActiveSheet.Paste
OS.Select
Selection.AutoFilter
End If
Next
Cells(SR - 1, FC).Select
Application.ScreenUpdating = True
End Sub

Set NS = ActiveWorkbook.Worksheets.Add(after:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count))
上面这个语句中Add是增加新表的意思，所以每次加了一个新表，改一下就可以了。
改成：Set NS = Application.Workbooks(ThisWorkbook.Name).Worksheets("张三")
或Set NS = ActiveWorkbook.Worksheets("张三")
或许你这程序就好了。当然张三这个表必须存在，不存在的话可是发出错的。
有问题不防到我主页上看看，上面我有的好多程序可以下载的的。

程序好象不对，意思也不大明白，最好附上原表

试试下面的;

Sub 按某列相同的值分到各工作表中()

Dim RowsCount As Integer
Dim FirstRow As Integer
Dim FirstCol As Integer
Dim i As Integer
Dim ShName As String

On Error Resume Next
FirstRow = ActiveCell.Row + 1
FirstCol = ActiveCell.Column

With ActiveSheet
RowsCount = .UsedRange.Rows.Count
For i = FirstRow To RowsCount
.Rows(i).Copy
ShName = .Cells(i, FirstCol)
If ShYes(ShName) Then
Sheets(ShName).Rows(FirstRow).Insert
Else
Sheets.Add after:=Sheets(ThisWorkbook.Sheets.Count)
ActiveSheet.Name = ShName
Sheets(ShName).Rows(FirstRow).Insert
End If
Next i
End With

End Sub

Function ShYes(ShName As String) As Boolean

On Error Resume Next
ShYes = Sheets(ShName).Index > 0

End Function