第1个回答 2010-08-12
可以不用VBA,直接用函数公式效果也相同。
假定原始表sheet1的c列是科目(例:语文、数学...),在sheet2的a2输入:
=INDEX(sheet1!A:A,SMALL(IF(sheet1!$C$2:$C$65536=$C$1,ROW(sheet1!$A$2:$A$65536),4^8),ROW(A1)))&""
公式下拉右拉
说明:sheet2的c1输入你想查找的科目(例:语文);公式是数组公式,同时按下ctrl+shift+enter三键结束。
第2个回答 2010-08-13
请先做好备份。
Option Explicit
Sub Macro1()
'
' Macro1 Macro
' 宏由 yzvvj 录制,时间: 2010/8/13
'
Dim file1, file2, RowStart%, RowEnd%, SaveName
'
file1 = ActiveWorkbook.Name
Range("A1:D65536").Sort Key1:=Range("C1"), Order1:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
SortMethod:=xlPinYin, DataOption1:=xlSortNormal
RowStart = 2
Do
Rows("1:1").Select
Selection.Copy
Workbooks.Add
ActiveSheet.Paste
Range("A2").Select
file2 = ActiveWorkbook.Name
Windows(file1).Activate
SaveName = Cells(RowStart, 3)
RowEnd = RowStart + 1
While (Cells(RowEnd, 3) = SaveName): RowEnd = RowEnd + 1: Wend
Rows(RowStart & ":" & RowEnd - 1).Select
Application.CutCopyMode = False
Selection.Copy
Windows(file2).Activate
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveWorkbook.SaveAs Filename:=SaveName & ".xls", _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
ActiveWindow.Close
RowStart = RowEnd
Loop While (Cells(RowStart, 3) <> "")
End Sub本回答被提问者采纳