|
发表于 2020-9-19 21:54
来自手机
|
显示全部楼层
下面是一个通用拆表的代码,你可以试试。(注意不要先建好表名,只保留总表.)
Sub 一表拆多表()
Dim d As Object, sht As Worksheet
Dim aData, aResult, aTemp, aKeys, i&, j&, k&, x&
Dim rngData As Range, rngGist As Range
Dim lngTitleCount&, lngGistCol&, lngColCount&
Dim rngFormat As Range
Dim strKey As String
Set d = CreateObject("scripting.dictionary")
Set rngGist = Application.InputBox("请框选拆分依据列!只能选择单列单元格区域!", Title:="提示", Type:=8)
lngGistCol = rngGist.Column
lngTitleCount = Val(Application.InputBox("请输入总表标题行的行数?"))
If lngTitleCount < 0 Then MsgBox "标题行数不能为负数,程序退出。": Exit Sub
Set rngData = ActiveSheet.UsedRange
Set rngFormat = ActiveSheet.Cells
aData = rngData.Value
lngGistCol = lngGistCol - rngData.Column + 1
lngColCount = UBound(aData, 2)
For i = lngTitleCount + 1 To UBound(aData)
If aData(i, lngGistCol) = "" Then aData(i, lngGistCol) = "单元格空白"
strKey = aData(i, lngGistCol)
If Not d.exists(strKey) Then
d(strKey) = i
Else
d(strKey) = d(strKey) & "," & i
End If
Next
Application.DisplayAlerts = False
For Each sht In ActiveWorkbook.Worksheets
If d.exists(sht.Name) Then sht.Delete
Next
Application.DisplayAlerts = True
aKeys = d.keys
Application.ScreenUpdating = False
For i = 0 To UBound(aKeys)
If aKeys(i) <> "" Then
aTemp = Split(d(aKeys(i)), ",")
ReDim aResult(1 To UBound(aTemp) + 1, 1 To lngColCount)
k = 0
For x = 0 To UBound(aTemp)
k = k + 1
For j = 1 To lngColCount
aResult(k, j) = aData(aTemp(x), j)
Next
Next
With Worksheets.Add(, Sheets(Sheets.Count))
.Name = aKeys(i)
.[a1].Resize(UBound(aData), lngColCount).NumberFormat = "@"
If lngTitleCount > 0 Then .[a1].Resize(lngTitleCount, lngColCount) = aData
.[a1].Offset(lngTitleCount, 0).Resize(k, lngColCount) = aResult
rngFormat.Copy
.[a1].PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
.[a1].Offset(lngTitleCount + k, 0).Resize(UBound(aData) - k - lngTitleCount, 1).EntireRow.Delete
.[a1].Select
End With
End If
Next
rngData.Parent.Activate
Application.ScreenUpdating = True
Set d = Nothing
Set rngData = Nothing
Set rngGist = Nothing
Set rngFormat = Nothing
Erase aData: Erase aResult
MsgBox "数据拆分完成!"
End Sub |
|