|
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
请测试:
Sub Macro1()
Dim wb As Workbook, arr, sh As Worksheet
Dim k, t, i&, j&, d As Object, ds As Object
Set d = CreateObject("scripting.dictionary")
Set ds = CreateObject("scripting.dictionary")
For Each sh In Sheets
Set ds(sh.Name) = CreateObject("scripting.dictionary")
arr = sh.UsedRange
For i = 4 To sh.Range("a65536").End(xlUp).Row
If Len(arr(i, 1)) Then
If Asc(arr(i, 1)) < 0 Then
d(arr(i, 1)) = ""
ds(sh.Name)(arr(i, 1)) = i
End If
End If
Next
ds(sh.Name)("") = i
Next
k = d.Keys
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With ThisWorkbook
For i = 0 To UBound(k)
Set wb = Workbooks.Add(xlWBATWorksheet)
For Each sh In .Sheets
sh.Copy After:=wb.Sheets(wb.Sheets.Count)
With wb.Sheets(wb.Sheets.Count)
t = ds(.Name).Items
arr = .UsedRange
For j = UBound(t) - 1 To 0 Step -1
If arr(t(j), 1) <> k(i) Then .Cells(t(j), 1).Resize(t(j + 1) - t(j)).EntireRow.Delete
Next
End With
Next
wb.Sheets(1).Delete
wb.SaveAs ThisWorkbook.Path & "\拆分表1\" & k(i) & ".xls"
wb.Close
Next
End With
MsgBox "ok"
End Sub |
评分
-
1
查看全部评分
-
|