如何写vba根据任意选择的字段名拆分工作表数据？

将单元格区域的数据按照某个字段进行拆分，是一个经常需要遇到的问题。

以下代码利用字典按照任意字段拆分单元格区域的数据，同时将拆分后的数据单独另存为一个excel工作簿。

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