Sub QQ1722187970()
Dim oRng As Range
Dim oRngHead As Range
Set oRng = Application.InputBox("请选择要拆分的字段名", "拆分", , , , , , 8)
Excel.Application.ScreenUpdating = False
Excel.Application.DisplayAlerts = False
Excel.Application.Calculation = xlCalculationManual
If oRng.Columns.Count > 1 Then
MsgBox "您未选择或者您选择的拆分字段有误,请重新选择"
Else
Dim oWK As Worksheet
Dim oDic As Object
Set oDic = CreateObject("scripting.dictionary")
With oRng
Set oWK = .Parent
iRow = .CurrentRegion.Rows(1).Row
iColField = .Column
With oWK
iRowEnd1 = .Cells(65536, iColField).End(xlUp).Row
iColEnd = .Cells(iRow, 256).End(xlToLeft).Column
iColStart = .Cells(iRow, iColField).End(xlToLeft).Column
iRowEnd2 = .Cells(65536, iColStart).End(xlUp).Row
Set oRngHead = .Cells(iRow, iColStart).Resize(1, iColEnd - iColStart + 1)
For i = iRow + 1 To Excel.Application.WorksheetFunction.Max(iRowEnd1, iRowEnd2)
Dim oRngTemp As Range
Set oRngTemp = .Cells(i, iColStart).Resize(1, iColEnd - iColStart + 1)
sText = .Cells(i, iColField).Value
If Not oDic.Exists(sText) Then
oDic.Add sText, oRngTemp
Else
Set oDic.Item(sText) = Excel.Application.Union(oDic.Item(sText), oRngTemp)
End If
Next i
arrKeys = oDic.keys
arrItems = oDic.items
For i = 0 To UBound(arrItems)
Dim oWB As Workbook
Set oWB = Excel.Application.Workbooks.Add
With oWB
Dim oWK1 As Worksheet
Set oWK1 = .Sheets(1)
With oWK1
oRngHead.Copy .Range("a1")
arrItems(i).Copy .Range("a2")
.Columns.AutoFit
End With
.SaveAs Excel.ThisWorkbook.Path & "\" & arrKeys(i), xlOpenXMLWorkbook
.Close
End With
Next i
End With
End With
End If
Excel.Application.Calculation = xlCalculationAutomatic
Excel.Application.DisplayAlerts = True
Excel.Application.ScreenUpdating = True
End Sub
