在工作表名稱上點右鍵選檢視程式碼,貼上以下程式碼到彈出視窗.關閉彈出視窗ALT+F8選中該宏執行

Sub拆分工作表()

Application.ScreenUpdating=False

DimrngAsRange,arr()

endrow=Range("A65536").End(xlUp).Row

ReDimarr(2,0)

arr(0,0)=Range("A2").Value

arr(1,0)=Range("A2").Row

arr(2,0)=Range("A2").Row

L=0

Fori=2Toendrow

temp=Range("A"&i).Value

Forii=i+1Toendrow

WithRange("A"&ii)

If.Value=tempThen

arr(2,L)=.Row

Else

L=L+1

ReDimPreservearr(2,L)

arr(0,L)=.Value

arr(1,L)=.Row

arr(2,L)=.Row

i=.Row-1

ExitFor

EndIf

EndWith

Next

Next

Fori=0ToL

Workbooks.Add

ActiveWorkbook.SaveAsThisWorkbook.Path&"\"&arr(0,i)

ActiveSheet.Name=arr(0,i)

ActiveSheet.Range("A:C").ColumnWidth=10

ActiveSheet.Range("A:C").HorizontalAlignment=xlCenter

ActiveSheet.Range("A:C").VerticalAlignment=xlCenter

ActiveSheet.Range("C:C").NumberFormatLocal="m-d"

ActiveSheet.Range("D:D").ColumnWidth=30

ThisWorkbook.Activate

Workbooks(arr(0,i)&".xls").Sheets(1).Rows(1).Value=Sheet1.Rows(1).Value

Forbc=arr(1,i)Toarr(2,i)

Workbooks(arr(0,i)&".xls").Sheets(1).Rows(bc-arr(1,i)+2).Value=Sheet1.Rows(bc).Value

Next

Workbooks(arr(0,i)&".xls").CloseSaveChanges:=True

Next

Application.ScreenUpdating=True

MsgBox"拆分工作表完成!"&vbCrLf&"在當前工作薄路徑下建立工作薄:"&L+1&"個."

EndSub