|
|
本帖最后由 3190496160 于 2020-3-8 17:07 编辑
基本思路：借助vba中的inputbox函数，自由选择标题区域，自由选择拆分后需要保留的列区域，自由选择拆分关键字所在列，从而实现了拆分的灵活和通用，
Sub 灵活拆分()
Dim d As Object
Dim rng1 As Range
Dim rng2 As Range
Dim rng3 As Range
Set d = CreateObject("scripting.dictionary")
Application.DisplayAlerts = False
For Each sh In Sheets
If sh.Name <> ActiveSheet.Name Then sh.Delete
Next sh
Application.DisplayAlerts = True
Set sh = ActiveSheet
On Error Resume Next
Set rng1 = Application.InputBox("请选择拆分后要保存的列区域区域", "选取提示", , , , , , 8)
If rng1 Is Nothing Then MsgBox "您没有选择要保存的列区域": Exit Sub
Set rng2 = Application.InputBox("请选择标题区域", "选取提示", , , , , , 8)
If rng2 Is Nothing Then MsgBox "您没有选择标题区域": Exit Sub
p1 = rng2.Rows.Count + rng2.Row - 1
Set rng3 = Application.InputBox("请选择拆分列", "选取提示", , , , , , 8)
If rng3 Is Nothing Then MsgBox "您没有选择拆分列": Exit Sub
p2 = rng3.Column
Application.ScreenUpdating = False
ks = rng1.Column
js = rng1.Columns.Count + rng1.Column - 1
With ActiveSheet
Set bt = .Range(.Cells(1, ks), .Cells(Val(p1), js))
x = .Cells(Rows.Count, p2).End(xlUp).Row
y = .Cells(p1, Columns.Count).End(xlToLeft).Column
ar = .Range(.Cells(1, 1), .Cells(x, y))
End With
For i = p1 + 1 To UBound(ar)
If Trim(ar(i, Val(p2))) <> "" Then
d(Trim(ar(i, Val(p2)))) = ""
End If
Next i
For Each k In d.keys
n = 0
ReDim br(1 To UBound(ar), 1 To (js - ks + 1))
For i = p1 + 1 To UBound(ar)
If Trim(ar(i, Val(p2))) = k Then
n = n + 1
y = 0
For j = ks To js
y = y + 1
br(n, y) = ar(i, j)
Next j
End If
Next i
Set sht = Worksheets.Add(after:=Sheets(Sheets.Count))
sht.Name = k
bt.Copy sht.[a1]
sht.Cells(p1 + 1, 1).Resize(n, UBound(br, 2)) = br
sht.Cells(p1 + 1, 1).Resize(n, UBound(br, 2)).Borders.LineStyle = 1
t = 0
For j = ks To js
t = t + 1
sht.Columns(t).ColumnWidth = sh.Columns(j).ColumnWidth
Next j
Next k
Application.ScreenUpdating = True
MsgBox "共生成了" & d.Count & "个工作表"
End Sub
|
评分
-
2
查看全部评分
-
|
[复制链接]
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2020-2-12 14:44
楼主
