Sub 分割()
Dim arr, sht As Worksheet, temp As String, i As Long, k, t, rng1 As Range
Dim x, xx As String
Dim x1, x2, y As Integer
x = UCase(InputBox("", "请输入标题列"))
y = InputBox("", "请输入标题行")
xx = UCase(InputBox("", "请输入最后一列"))
x1 = Asc(x) - 64
x2 = Asc(xx) - 64
Set rng1 = Range("A1:" & xx & y)
Dim z As Range
Set z = Range("" & x & 65536)
arr = Range("A" & y + 1 & ":" & x & z.End(xlUp).Row).Value '减去黄色区域
Application.ScreenUpdating = False
With CreateObject("scripting.dictionary")
For i = 1 To UBound(arr)
temp = arr(i, x1)
If temp <> "" Then
If Not .exists(temp) Then
.Add temp, Range("a" & i + y).Resize(1, x2)
Else
Set .Item(temp) = Union(.Item(temp), Range("a" & i + y).Resize(1, x2))
End If
End If
Next i
k = .keys
t = .Items
On Error Resume Next
For i = 0 To .Count - 1
If Len(Sheets(k(i)).Name) > 0 Then '判断工作表存在
If Err.Number = 9 Then '如果不存在则添加
Sheets.Add(after:=Sheets(Sheets.Count)).Name = k(i)
End If
End If
With Sheets(k(i))
.Cells.Clear
rng1.Copy .Range("a1") '把表头的前两行也一同复制到新工作表中
t(i).Copy .Range("a" & y + 1)
End With
Next
End With
Application.ScreenUpdating = True
MsgBox "处理完毕"
End Sub
VBA根据某列值分割多Sheet
猜你喜欢
转载自qqt31.iteye.com/blog/2246864
今日推荐
周排行