|
Sub 拆分数据为工作表()
Dim i As Long
Dim d As Object
Set d = CreateObject("scripting.dictionary")
Application.DisplayAlerts = False
For Each sh In Sheets
If sh.Index > 1 Then sh.Delete
Next sh
Application.DisplayAlerts = True
ar = Sheets("设备使用记录").[a1].CurrentRegion
For i = 1 To UBound(ar)
If Trim(ar(i, 4)) <> "" Then
If Not d.exists(Trim(ar(i, 4))) Then
Set d(Trim(ar(i, 4))) = Sheets("设备使用记录").Range("a" & i).Resize(1, UBound(ar, 2))
Else
Set d(Trim(ar(i, 4))) = Union(d(Trim(ar(i, 4))), Sheets("设备使用记录").Range("a" & i).Resize(1, UBound(ar, 2)))
End If
End If
Next i
x = d.keys
For i = 0 To UBound(x)
Set sh = Sheets.Add(after:=Sheets(Sheets.Count))
sh.Name = x(i)
Sheets("设备使用记录").Range("a1:f1").Copy sh.[a1]
d.items()(i).Copy sh.[a2]
Next i
End Sub
|
|