|
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
Sub 拆分生成()
Application.ScreenUpdating = False
Dim i, n, j, p, mm!, arr, brr, crr(1 To 100, 1 To 5)
arr = [A1].CurrentRegion
mm = InputBox("请输入拆分依据的列号", "列号")
For i = 2 To UBound(arr)
n = n + 1
If arr(i, mm) <> Cells(i + 1, mm) Then
brr = [A1:E1]
For m = i - n + 1 To i
p = p + 1
For j = 1 To 5
crr(p, j) = arr(m, j)
Next
Next
pp = ThisWorkbook.Path & "\"
temp = arr(i, mm) & ".xlsx"
With Workbooks.Add
.SaveAs pp & temp
ActiveSheet.Name = arr(i, mm)
ActiveSheet.[A1].Resize(UBound(brr), 5) = brr
ActiveSheet.[a2].Resize(UBound(crr), 5) = crr
ActiveSheet.[A1].CurrentRegion.HorizontalAlignment = Excel.xlCenter
ActiveSheet.[A1].CurrentRegion.Borders.LineStyle = xlContinuous
.Close True
End With
n = 0: p = 0: Erase crr
End If
Next
MsgBox "拆分完毕!"
Application.ScreenUpdating = True
End Sub
拿去改改用吧! |
|