在工作表名称上点右键选查看代码,粘贴以下代码到弹出窗口.关闭弹出窗口 ALT+F8选中该宏执行

Sub 拆分工作表()

Application.ScreenUpdating = False

Dim rng As Range, arr()

endrow = Range(“A65536”).End(xlUp).Row

ReDim arr(2, 0)

arr(0, 0) = Range(“A2”).Value

arr(1, 0) = Range(“A2”).Row

arr(2, 0) = Range(“A2”).Row

L = 0

For i = 2 To endrow

temp = Range(“A” & i).Value

For ii = i + 1 To endrow

With Range(“A” & ii)

If .Value = temp Then

arr(2, L) = .Row

Else

L = L + 1

ReDim Preserve arr(2, L)

arr(0, L) = .Value

arr(1, L) = .Row

arr(2, L) = .Row

i = .Row – 1

Exit For

End If

End With

Next

Next

For i = 0 To L

Workbooks.Add

ActiveWorkbook.SaveAs ThisWorkbook.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

For bc = arr(1, i) To arr(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”).Close SaveChanges:=True

Next

Application.ScreenUpdating = True

MsgBox “拆分工作表完成!” & vbCrLf & “在当前工作薄路径下创建工作薄:” & L + 1 & “个.”

End Sub