|
Sub 拆分()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim ar As Variant
Dim i As Long
Dim d As Object
Set d = CreateObject("scripting.dictionary")
lh = InputBox("请输入拆分列的列号", "列号", "9")
If lh = "" Then End
hs = InputBox("请输入标题行数", "行数", "1")
If hs = "" Then End
Set sh = ThisWorkbook.Worksheets("模板")
With Sheets("明细查询")
r = .Cells(Rows.Count, Val(lh)).End(xlUp).Row
y = .Cells(1, Columns.Count).End(xlToLeft).Column
If r < hs + 1 Then MsgBox "数据源为空!": End
If Val(lh) > y Then MsgBox "输入的列号超出了数据的最大列": End
ar = .Range(.Cells(1, 1), .Cells(r, y))
End With
For i = Val(hs) + 1 To UBound(ar)
If Trim(ar(i, Val(lh))) <> "" Then
d(Trim(ar(i, Val(lh)))) = ""
End If
Next i
For Each k In d.keys
n = 0
ReDim br(1 To UBound(ar), 1 To UBound(ar, 2))
For i = Val(hs) + 1 To UBound(ar)
If Trim(ar(i, Val(lh))) = k Then
n = n + 1
br(n, 1) = ar(i, 9)
br(n, 2) = ar(i, 10)
For j = 1 To 8
br(n, j + 2) = ar(i, j)
Next j
br(n, 11) = ar(i, 11)
End If
Next i
sh.Copy
Set wb = ActiveWorkbook
With wb.Worksheets(1)
.Name = k
.[b3] = k
.[a6].Resize(n, UBound(br, 2)) = br
.Rows(n + 6 & ":125").Delete
End With
wb.SaveAs Filename:=ThisWorkbook.Path & "\" & k & ".xlsx"
wb.Close
Next k
Set d = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "拆分完毕!"
End Sub
|
|