Excel - 根据指定列拆分文件

Excel - 根据指定列拆分文件

写本文的原因是因为在知乎上面看到了饼干数数的专栏中的一篇文章，公众号中提供了按指定列拆分文件的 VBA 代码。

Sub Main()
    '创建文件夹
    Dim iPath As String
    iPath = ThisWorkbook.Path & "\拆分结果"
    If Dir(iPath, vbDirectory) = "" Then
        MkDir iPath
    ElseIf MsgBox("　　目标文件夹已存在，若继续操作将覆盖同名文件，是否继续？", vbOKCancel) = vbCancel Then
        Exit Sub
    End If
    iPath = iPath & "\"
    '自定义排序
    With ActiveSheet.Sort
        .SortFields.Clear
        .SortFields.Add _
            Key:=[A1], _
            SortOn:=xlSortOnValues, _
            Order:=xlAscending, _
            DataOption:=xlSortNormal
        .SetRange [A1].CurrentRegion
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    '主体循环
    Dim iWkb As Workbook, nWkb As Integer
    Dim i As Integer, j As Integer
    Application.DisplayAlerts = False
    nWkb = 0
    With ActiveSheet
        j = 2
        For i = 2 To .[A1].CurrentRegion.Rows.Count
            If .Range("A" & i) <> .Range("A" & i + 1) Then
                Set iWkb = Workbooks.Add
                .[A1].Resize(1, 3).Copy [A1]
                .Range("A" & j).Resize(i - j + 1, 3).Copy [A2]
                iWkb.SaveAs iPath & .Range("A" & i)
                iWkb.Close False
                j = i + 1
                nWkb = nWkb + 1
            End If
        Next
    End With
    Application.DisplayAlerts = True
    MsgBox ("　　本次共拆分了 " & nWkb & " 份~")
End Sub

因为上面的代码中筛选选定的是 A 列，试着改了一下，增加通用性，需要将参数写在第二张表的 B3 和 B4 的单元格，而需要拆分的数据放在第一张表，而且筛选项必须放在第一行。

Sub Main()
    Application.ScreenUpdating = False
    Worksheets(1).Activate
    apc = Worksheets(2).Range("B3").Value
    apr = Worksheets(2).Range("B4").Value
    '创建文件夹
    Dim iPath As String
    iPath = ThisWorkbook.Path & "\拆分结果"
    If Dir(iPath, vbDirectory) = "" Then
        MkDir iPath
    ElseIf MsgBox("　　目标文件夹已存在，若继续操作将覆盖同名文件，是否继续？", vbOKCancel) = vbCancel Then
        Exit Sub
    End If
    iPath = iPath & "\"
    '自定义排序
    With ActiveSheet.Sort
        .SortFields.Clear
        .SortFields.Add _
            Key:=Range( apc & apr), _
            SortOn:=xlSortOnValues, _
            Order:=xlAscending, _
            DataOption:=xlSortNormal
        .SetRange [A1].CurrentRegion
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    '主体循环
    Dim iWkb As Workbook, nWkb As Integer
    Dim i As Integer, j As Integer, k As Integer
    Application.DisplayAlerts = False
    nWkb = 0
    With ActiveSheet
        j = 2
        k = WorksheetFunction.CountA(Range("1:1"))
        For i = 2 To .[A1].CurrentRegion.Rows.Count
            If .Range(apc & i) <> .Range(apc & i + 1) Then
                Set iWkb = Workbooks.Add
                .[A1].Resize(1, k).Copy [A1]
                .Range("A" & j).Resize(i - j + 1, 3).Copy [A2]
                iWkb.SaveAs iPath & .Range(apc & i)
                iWkb.Close False
                j = i + 1
                nWkb = nWkb + 1
            End If
        Next
    End With
    Application.DisplayAlerts = True
    MsgBox ("　　本次共拆分了 " & nWkb & " 份~")
    Worksheets(2).Activate
    Application.ScreenUpdating = False
End Sub

在实际工作中测试发现当条目很多的时候会溢出，可以考虑将多条目的文件用排序后手工先分成两个，之后分别拆分。