|
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
Sub 拆分()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set d = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")
With Worksheets("Temp")
.AutoFilterMode = False
r = .Cells(.Rows.Count, 1).End(xlUp).Row
ar = .Range("a1:i" & r)
End With
For Each sh In Sheets
If sh.Index > 2 Then
sh.Delete
End If
Next sh
With Worksheets("对照表")
.AutoFilterMode = False
rs = .UsedRange.Rows.Count
br = .Range("a1:c" & rs)
End With
For j = 1 To 3
d.RemoveAll
n = 0
ReDim cr(1 To UBound(ar), 1 To UBound(ar, 2))
For i = 2 To UBound(br)
If br(i, j) <> "" Then
d(br(i, j)) = ""
End If
Next i
For i = 2 To UBound(ar)
If d.exists(ar(i, 2)) Then
n = n + 1
For s = 1 To UBound(ar, 2)
cr(n, s) = ar(i, s)
Next s
End If
Next i
If n > 0 Then
Worksheets("Temp").Copy after:=Sheets(Sheets.Count)
With ActiveSheet
.Name = br(1, j)
.UsedRange.Offset(1).Borders.LineStyle = 0
.UsedRange.Offset(1) = Empty
.[a2].Resize(n, UBound(cr, 2)) = cr
End With
End If
Next j
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "ok!"
End Sub
|
|