Option Explicit
Sub 拆分工作表()
Application.ScreenUpdating = True
Dim br, x As Integer, sh As Worksheet, d As New Dictionary, i As Integer, rg As Range, k As Integer, j As Integer, arr(), l As Integer
i = Range("A2").End(xlDown).Row
For Each rg In Range("H3:H" & i)
d(rg.Value) = ""
Next
For k = 0 To d.Count - 1
For j = 3 To i
If Range("H" & j) = d.Keys(k) Then
x = x + 1
ReDim Preserve arr(1 To 12, 1 To x)
arr(1, x) = x
arr(2, x) = Range("B" & j)
arr(3, x) = Range("C" & j)
arr(4, x) = Range("D" & j)
arr(5, x) = Range("E" & j)
arr(6, x) = Range("F" & j)
arr(7, x) = Range("G" & j)
arr(8, x) = Range("H" & j)
arr(9, x) = Range("I" & j)
arr(10, x) = Range("J" & j)
arr(11, x) = Range("K" & j)
arr(12, x) = Range("L" & j)
End If
Next j
Set sh = Sheets.Add(, Sheets(Sheets.Count))
sh.Name = d.Keys(k)
sh.Range("a1:l1").Merge
sh.Range("a1") = "开阳县水利局2015年9月21日一2015年 月 日车辆用油清册"
sh.Range("a1").HorizontalAlignment = xlCenter
sh.Range("a2:L2") = Array("序号", "出车时间", "小车车号", "出差地点", "事由", "用车人", "圈油时间", "驾驶员", "卡号", "金额", "驾驶员签字", "备注")
sh.Range("a3").Resize(UBound(arr, 2), 12) = WorksheetFunction.Transpose(arr)
sh.Range("a3:L" & (UBound(arr, 2) + 2)).HorizontalAlignment = xlCenter
br = Array(6.5, 17, 8.38, 11, 16, 15, 12, 12, 8.38, 8.38, 10, 30)
For x = 1 To 12
sh.Columns(x).ColumnWidth = br(x - 1)
Next x
Erase arr: x = 0
Sheets("汇总表").Activate
Next k
Application.ScreenUpdating = False
End Sub本文出自 “开始跑” 博客，请务必保留此出处http://splend.blog.51cto.com/3717743/1704007
原文：http://splend.blog.51cto.com/3717743/1704007