Excel VBA--按某一列拆分数据到多个文件

首先，将需要拆分的sheet命名为“明细”，接下来运行此代码，按提示操作即可。

在这里插入代码片
Sub chaifen()
'定义变量类型
Dim sht, sh1, sh2 As Worksheet
Dim k, i, j As Integer
Dim irow As Integer
Dim col As Integer
Dim str As String

'程序开始是要求输入按哪一列拆分数据
col = InputBox("请输入你要按哪一列拆分数据")

'获取所选择的文件夹路径
  Set fileDlg = Application.FileDialog(msoFileDialogFolderPicker)

  With fileDlg

      If .Show = -1 Then

           For Each fld In .SelectedItems

                str = fld

           Next fld

      End If

  End With





Application.ScreenUpdating = False '防止屏幕一直闪动


'开始时先删除无意义的表，只留下需要拆分的sheet
Application.DisplayAlerts = False '防止程序运行中弹出警告

If Sheets.Count > 1 Then
    For Each sht1 In Sheets
        If sht1.Name <> "明细" Then
            sht1.Delete
        End If
    Next
End If

Application.DisplayAlerts = True

'拆分明细这张sheet
irow = Sheet1.Range("a1048576").End(xlUp).Row '用于计算sheet1一共有几行
For i = 2 To irow
    k = 0
    For Each sht In Sheets
        If sht.Name = Sheet1.Cells(i, col) Then
            k = 1
        End If
    Next
    
    If k = 0 Then
        Sheets.Add after:=Sheets(Sheets.Count)
        Sheets(Sheets.Count).Name = Sheet1.Cells(i, col)
    End If
Next
'拷贝数据到“明细”后面的sheet2,sheet3,sheet4....中
For j = 2 To Sheets.Count
    Sheet1.Range("a1:s" & irow).AutoFilter Field:=col, Criteria1:=Sheets(j).Name
    Sheet1.Range("a1:s" & irow).Copy Sheets(j).Range("a1")
Next

Sheet1.Range("a1:s" & irow).AutoFilter '取消筛选
Sheet1.Select




'将其中的sheets拆分为多个Excel文件

For Each sht2 In Sheets
    If sht2.Name <> "明细" Then
        sht2.Copy
        ActiveWorkbook.SaveAs Filename:=str & "\" & sht2.Name & ".xlsx"
        ActiveWorkbook.Close
    End If
Next

Application.ScreenUpdating = True
MsgBox "已处理完毕"


End Sub