Excel拆分多个表格，并保存多个文件，（xlsx或者csv格式）

Posted 2022-02-03 SC_lzl

> 第一部分 一表拆为多个子表单

以下涉及代码转自https://blog.csdn.net/qq_41554671/article/details/87621830?ops_request_misc=%257B%2522request%255Fid%2522%253A%2522164154989716780264010798%2522%252C%2522scm%2522%253A%252220140713.130102334…%2522%257D&request_id=164154989716780264010798&biz_id=0&utm_medium=distribute.pc_search_result.none-task-blog-2_allbaidu_landing_v2~default-1-87621830.first_rank_v2_pc_rank_v29&utm_term=Excel%E6%8B%86%E5%88%86%E5%A4%9A%E4%B8%AA%E5%AD%90%E8%A1%A8&spm=1018.2226.3001.4187

一、原始数据表如下（sheet页名称为：数据源），需要根据A列部门拆分成每个部门一个工作表。

二、进入VBE编辑页面（4种途径）

通过【开发工具】>>【查看代码】进入编辑页面
通过【开发工具】>>【visual Basic】进入编辑页面
通过【右击】sheet页名称，选择【查看代码】进入编辑页面
通过ALT+F11进入编辑页
（图为第2种）

三、插入一个新的模块

四、在模块1窗口粘入如下代码 ,并保存

Sub CFGZB()
    Dim myRange As Variant
    Dim myArray
    Dim titleRange As Range
    Dim title As Variant
    Dim columnNum As Integer
    myRange = Application.InputBox(prompt:="请选择标题行：", Type:=8)
    myArray = WorksheetFunction.Transpose(myRange)
    Set titleRange = Application.InputBox(prompt:="请选择拆分的表头，必须是第一行，且为一个单元格，如：“组织”", Type:=8)
    title = titleRange.Value
    columnNum = titleRange.Column
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Dim i&, Myr&, Arr, num&
    Dim d, k
    For i = Sheets.Count To 1 Step -1
        If Sheets(i).Name <> "数据源" Then
          
        End If
    Next i
    Set d = CreateObject("Scripting.Dictionary")
    Myr = Worksheets("数据源").UsedRange.Rows.Count
    Arr = Worksheets("数据源").Range(Cells(2, columnNum), Cells(Myr, columnNum))
    For i = 1 To UBound(Arr)
        d(Arr(i, 1)) = ""
    Next
    k = d.keys
    For i = 0 To UBound(k)
        Set conn = CreateObject("adodb.connection")
        conn.Open "provider=Microsoft.ACE.OLEDB.12.0;extended properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
        Sql = "select * from [数据源$] where " & title & " = '" & k(i) & "'"
        Worksheets.Add after:=Sheets(Sheets.Count)
        With ActiveSheet
            .Name = k(i)
            For num = 1 To UBound(myArray)
                .Cells(1, num) = myArray(num, 1)
            Next num
            .Range("A2").CopyFromRecordset conn.Execute(Sql)
        End With
        Sheets(1).Select
        Sheets(1).Cells.Select
        Selection.Copy
        Worksheets(Sheets.Count).Activate
        ActiveSheet.Cells.Select
        Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        Application.CutCopyMode = False
    Next i
    conn.Close
    Set conn = Nothing
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

五、执行程序

第二部分 多个子表保存为多个文件

同上操作方式，进入VBE编辑页面，新增一个模块，粘上以下代码

Sub 拆分工作薄()
    Dim xpath As String
    xpath = ActiveWorkbook.Path
    Dim sht As Worksheet
    For Each sht In ActiveWorkbook.Sheets
        sht.Copy
        ActiveWorkbook.SaveAs Filename:=xpath & "\\" & sht.Name & ".xlsx"
        ActiveWorkbook.Close
    Next
         MsgBox "工作薄拆分完毕！"
End Sub

点击上方的小三角直接运行代码，等待一段时间，拆分完毕后会跳出一个【工作薄拆分完毕】的提示，直接点击确定即可，拆分的Excel文件的保存路径与这个打开的Excel文件路径是一致的
一般文件格式是.xlsx;

第三部分 多个.xlsx格式批量转成csv格式

首先，需要把要.xlsx文件放在同一个文件夹，复制下文件夹地址；

然后新建一个空文件夹，复制下文件夹地址，用于存放csv格式；

新建一个空表格，进入VBE编辑页面，新增一个模块，粘贴上以下代码并执行：

代码中的fPath = “C:\\Users\\qiany\\Desktop\\文件” -定义为需要转换成CSV的Excel源文件。
sPath = “C:\\Users\\qiany\\Desktop\\csv保存位置” -定义为转换后的CSV文件保存位置。

这两个位置需要自己按实际修改。特别注意：路径需要以\\结尾。

ub SaveToCSVs()

    Dim fDir As String

    Dim wB As Workbook

    Dim wS As Worksheet

    Dim fPath As String

    Dim sPath As String

    fPath = "C:\\Users\\qiany\\Desktop\\文件\\"

    sPath = "C:\\Users\\qiany\\Desktop\\csv保存位置\\"

    fDir = Dir(fPath)

    Do While (fDir <> "")

        If Right(fDir, 4) = ".xls" Or Right(fDir, 5) = ".xlsx" Then

            On Error Resume Next

            Set wB = Workbooks.Open(fPath & fDir)

            'MsgBox (wB.Name)

            For Each wS In wB.Sheets

                wS.SaveAs sPath & wB.Name & ".csv", xlCSV

            Next wS

            wB.Close False

            Set wB = Nothing

        End If

        fDir = Dir

        On Error GoTo 0

    Loop

End Sub

这样你就得到了转化为csv格式的文件啦