测试使用－－

`

' 选择保存拆分数据后工作簿的文件夹路径

Sub SplitDataAndCopySheets_ExcludeOriginalDataSheet()
Dim d As Object
Dim aData As Variant, aResult As Variant, aRef As Variant
Dim rngData As Range, rngGist As Range, rngFormat As Range
Dim wsOriginal As Workbook, ws As Workbook
Dim wsOriginalSheet As Worksheet
Dim lngTitleCount As Long, lngGistCol As Long, lngColCount As Long
Dim strYesOrNo As String, strKey As String, strPath As String, strFileName As String
Dim i As Long, j As Long, k As Long, x As Long
On Error Resume Next

' 选择保存拆分数据后工作簿的文件夹路径
With Application.FileDialog(msoFileDialogFolderPicker)If .Show Then strPath = .SelectedItems(1) Else Exit Sub
End With
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"' 打开原始工作簿
Set wsOriginal = ThisWorkbook' 选择要拆分数据的列
Set rngGist = Application.InputBox("请选择要拆分数据的列！只能选择单列单元格范围！", Title:="选择数据列", Type:=8)
If rngGist Is Nothing Then Exit Sub
lngGistCol = rngGist.Column' 输入主工作表中标题行的数量
lngTitleCount = Val(Application.InputBox("请输入主工作表中标题行的数量？", Default:=1))
If lngTitleCount < 0 Then MsgBox "标题行数不能为负数，程序退出。": Exit Sub' 是否保留拆分工作表中的格式
strYesOrNo = MsgBox("是否保留拆分工作表中的格式？", vbYesNo)' 输入文件名
strFileName = InputBox("请输入文件名（标题列将会在文件名中间，用 - 隔开）：")' 设置数据范围和格式范围
Set rngData = rngGist.Parent.UsedRange
Set rngFormat = rngGist.Parent.Cells' 将数据读入数组
aData = rngData.Value
lngGistCol = lngGistCol - rngData.Column + 1
lngColCount = UBound(aData, 2)' 初始化数据结构
ReDim aRef(1 To UBound(aData))' 创建字典对象
Set d = CreateObject("scripting.dictionary")' 遍历数据，根据选择的列生成键值
For i = 1 To UBound(aData)If IsError(aData(i, lngGistCol)) ThenaRef(i) = "Error Value"ElseIf aData(i, lngGistCol) = "" ThenDim strTemp As StringstrTemp = ""For j = 1 To lngColCountstrTemp = strTemp & aData(i, j)NextIf strTemp = "" ThenaRef(i) = "Entire Row Blank"ElseaRef(i) = "Blank Cell"End IfElsestrKey = aData(i, lngGistCol)aRef(i) = strKeyEnd If
Next' 根据键值拆分数据并保存到新工作簿
For i = lngTitleCount + 1 To UBound(aData)strKey = aRef(i)If strKey <> "Entire Row Blank" And WorksheetFunction.CountA(rngData.Rows(i)) > 0 ThenIf Not d.exists(strKey) Thend(strKey) = ""ReDim aResult(1 To UBound(aData), 1 To lngColCount)k = 0For x = lngTitleCount + 1 To UBound(aData)strTemp = aRef(x)If strTemp = strKey ThenIf aData(x, lngGistCol) <> "" Then ' 检查指定列是否为空k = k + 1For j = 1 To lngColCountaResult(k, j) = aData(x, j)NextEnd IfEnd IfNext' 创建新工作簿Set ws = Workbooks.AddWith ws.Sheets(1).Name = Left$(strKey, 31)  ' 截取 strKey 的前 31 个字符.Range("a1").Resize(UBound(aData), lngColCount).NumberFormat = "@"If lngTitleCount > 0 Then .Range("a1").Resize(lngTitleCount, lngColCount) = aData.Range("a1").Offset(lngTitleCount, 0).Resize(k, lngColCount) = aResultIf strYesOrNo = vbYes ThenrngFormat.Copy.Range("a1").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=FalseFor Each cell In rngDataIf cell.HasFormula Then.Cells(cell.Row, cell.Column).Formula = cell.FormulaEnd IfNext cellEnd If' 复制原始工作簿中的其他工作表，排除拆分数据的工作表For Each wsOriginalSheet In wsOriginal.SheetsIf wsOriginalSheet.Name <> rngData.Parent.Name ThenwsOriginalSheet.Copy After:=ws.Sheets(ws.Sheets.Count)End IfNext wsOriginalSheet' 生成文件名并确保不超过31个字符Dim strFullFileName As StringIf strFileName <> "" ThenstrFullFileName = strFileName & " - " & strKeyElsestrFullFileName = strKeyEnd IfstrFullFileName = Left$(strFullFileName, 31)' 保存新工作簿并关闭ws.SaveAs strPath & strFullFileName, xlWorkbookDefaultws.Close FalseEnd WithEnd IfEnd If
Next' 清理资源
Set d = Nothing
Set rngData = Nothing
Set rngGist = Nothing
Set rngFormat = Nothing
Erase aData
Erase aResult' 提示拆分完成
MsgBox "数据拆分完成！"
End Sub

`