|
- Sub 拆分()
- Dim arr
- Dim wb As Workbook
- Application.ScreenUpdating = False
- Application.DisplayAlerts = False
- Set d = CreateObject("scripting.dictionary")
- With Worksheets("出库单")
- r = .Cells(.Rows.Count, 1).End(xlUp).Row
- arr = .Range("a1:u" & r)
- For i = 2 To UBound(arr)
- If Not d.exists(arr(i, 21)) Then
- Set d(arr(i, 21)) = .Cells(1, 1).Resize(1, 21)
- Else
- Set d(arr(i, 21)) = Union(d(arr(i, 21)), .Cells(i, 1).Resize(1, 21))
- End If
- Next
- End With
- For Each aa In d.keys
- Set wb = Workbooks.Add
- With wb
- With .Worksheets(1)
- d(aa).Copy .Range("a1")
- .Name = aa & "部门"
- End With
- .SaveAs Filename:=ThisWorkbook.Path & "\各部门信息" & aa & "部门"
- .Close False
- End With
- Next
- Application.ScreenUpdating = True
- MsgBox "数据拆分完毕!"
- End Sub
复制代码 |
|