|
|
在实际工作中，有时候需要根据设定的列表对一个工作表中的数据进行拆分，或者拆分为多个工作表，或者拆分为多个工作簿文件，本工具特为这个需求而写，Sub 拆分之四()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim d As Object
Dim ar As Variant, br As Variant
Dim arr()
Set d = CreateObject("scripting.dictionary")
w = InputBox("请输入数据源表中列标题行数", , "1")
If w = "" Then MsgBox "您没有输入数据源表中列标题行数": Exit Sub
x = InputBox("请输入数据源表中拆分依据列的列号", , "8")
If x = "" Then MsgBox "您没有输入数据源表中拆分依据列的列号": Exit Sub
p = MsgBox("拆分为工作表请选择是，拆分为工作簿请选择否", vbYesNoCancel)
If p = vbCancel Then Exit Sub
If p = vbYes Then
For Each sh In Sheets
If sh.Name <> "数据源" And sh.Name <> "拆分列表" Then
sh.Delete
End If
Next sh
End If
ar = Sheets("拆分列表").[a1].CurrentRegion
With Sheets("数据源")
r = .Cells(Rows.Count, 8).End(xlUp).Row
y = .Cells(1, Columns.Count).End(xlToLeft).Column
br = .Range(.Cells(1, 1), .Cells(r, y))
End With
Set Rng = ThisWorkbook.Worksheets("数据源").Rows(1)
For j = 1 To UBound(ar, 2)
If Trim(br(1, j)) <> "" Then
n = 0
ReDim arr(1 To UBound(br), 1 To UBound(br, 2))
d.RemoveAll
For i = 2 To UBound(ar)
If Trim(ar(i, j)) <> "" Then
d(Trim(ar(i, j))) = ""
End If
Next i
For i = Val(w) + 1 To UBound(br)
If Trim(br(i, Val(x))) <> "" Then
mc = Trim(br(i, Val(x)))
If d.Exists(Trim(mc)) Then
n = n + 1
For jj = 1 To UBound(br, 2)
arr(n, jj) = br(i, jj)
Next jj
End If
End If
Next i
If n <> 0 Then
If p = vbYes Then
Set sht = Sheets.Add(after:=Sheets(Sheets.Count))
With sht
.Name = ar(1, j)
.[a1].CurrentRegion = Empty
Rng.Copy .[a1]
.Cells(w + 1, 1).Resize(n, UBound(arr, 2)) = arr
End With
ElseIf p = vbNo Then
Set wb = Workbooks.Add
With wb.Worksheets(1)
.Name = ar(1, j)
Rng.Copy .[a1]
.Cells(w + 1, 1).Resize(n, UBound(arr, 2)) = arr
End With
wb.SaveAs Filename:=ThisWorkbook.Path & "\" & ar(1, j)
wb.Close
End If
End If
End If
Next j
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub
|
评分
-
4
查看全部评分
-
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2020-7-20 16:15
楼主
所以建议你弄多一个功能，或者增加一个选项，是否保留完整格式。是，则调用复制删除法去拆分
