|
|
Sub 拆分()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set d = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")
Set sh = ThisWorkbook.Worksheets("数据")
With Sheets("密码")
r = .Cells(Rows.Count, 1).End(xlUp).Row
ar = .Range("a1:b" & r)
End With
For i = 2 To UBound(ar)
dc(Trim(ar(i, 1))) = ar(i, 2)
Next i
sh.Select
arr = sh.[a1].CurrentRegion
p = InputBox("请输入标题行数", , "1")
If p = "" Then Exit Sub
pp = InputBox("请输入拆分列的列号", , "2")
If pp = "" Then Exit Sub
For i = Val(p + 1) To UBound(arr)
If Len(Trim(arr(i, pp))) > 0 Then
If Not d.exists(Trim(arr(i, pp))) Then
Set d(Trim(arr(i, pp))) = sh.Range("a" & i).Resize(1, UBound(arr, 2))
Else
Set d(Trim(arr(i, pp))) = Union(d(Trim(arr(i, pp))), sh.Range("a" & i).Resize(1, UBound(arr, 2)))
End If
End If
Next i
x = d.keys
Application.SheetsInNewWorkbook = 1
For i = 0 To UBound(x)
Set wb = Workbooks.Add
With wb.Worksheets(1)
sh.Rows("1:" & p).Copy .[a1]
d.items()(i).Copy .Cells(p + 1, 1)
End With
mm = dc(x(i))
wb.SaveAs Filename:=ThisWorkbook.Path & "\" & x(i) & ".xlsx", Password:=mm '''保存为xlsx文件
'wb.SaveAs ThisWorkbook.Path & "\" & x(i) & ".xlsm", xlOpenXMLWorkbookMacroEnabled, mm'''保存为启用宏的文件
wb.Close
Next i
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "OK!"
End Sub
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2024-2-7 16:10
楼主
