胜芳新闻,胜芳资讯

Sub 拆分工作簿为多个sheet()

Set d = CreateObject("scripting.dictionary")

With Worksheets(1)

rrow = .Cells(Rows.Count, "a").End(3).Row

For i = 2 To rrow '从第2行开始拆分

strr = .Range("B" & i).Value '拆分B列内容

If Not d.exists(strr) Then

d.Add strr, .Range("a" & i).Resize(1, 10)

Else

Set d.Item(strr) = Union(d.Item(strr), .Range("a" & i).Resize(1, 10))

End If

Next

k = d.keys

i = d.items

For a = 0 To d.Count - 1

Worksheets.Add.Name = k(a)

i(a).Copy Worksheets(k(a)).Range("a2")

Next

End With

End Sub