按照某列属性拆分Excel文件

Posted 2022-01-03 RS&Hydrology

1.利用Excel中开发工具[https://blog.csdn.net/ntotl/article/details/79141314](https://blog.csdn.net/ntotl/article/details/79141314)
（1）打开需要拆分的Excel文件，Alt+F11打开VBE窗口；
（2）插入——模块，输入代码：

Sub 保留表头拆分数据为若干新工作簿()
    Dim arr, d As Object, k, t, i&, lc%, rng As Range, c%
    c = Application.InputBox("请输入拆分列号", , 4, , , , , 1)
    If c = 0 Then Exit Sub
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    arr = [a1].CurrentRegion
    lc = UBound(arr, 2)
    Set rng = [a1].Resize(, lc)
    Set d = CreateObject("scripting.dictionary")
    For i = 2 To UBound(arr)
        If Not d.Exists(arr(i, c)) Then
            Set d(arr(i, c)) = Cells(i, 1).Resize(1, lc)
        Else
            Set d(arr(i, c)) = Union(d(arr(i, c)), Cells(i, 1).Resize(1, lc))
        End If
    Next
    k = d.Keys
    t = d.Items
    For i = 0 To d.Count - 1
        With Workbooks.Add(xlWBATWorksheet)
            rng.Copy .Sheets(1).[a1]
            t(i).Copy .Sheets(1).[a2]
            .SaveAs Filename:=ThisWorkbook.Path & "\\" & k(i) & ".xls"
            .Close
        End With
    Next
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "完毕"
End Sub

转自https://blog.csdn.net/ntotl/article/details/79141314代码。

注意分拆分后的Excel文件格式为xls。
（3）开发工具——插入——按钮

会形成一个按钮，点击该窗体控件，加载刚刚建立的宏，设置拆分序列号，即根据哪一列属性拆分（class）。
（4）完成操作

2.VBA批量将xls文件转换成xlsx文件
（1）新建一个Excel（与需要转换文件同一目录）；
（2）输入代码：

Sub xls2xlsx()
Dim FilePath, MyFile, iPath, Name, OutPath As String
iPath = ThisWorkbook.Path
OutPath = Dir(iPath & "\\xlsx", vbDirectory)
If OutPath = "" Then
    MkDir (iPath & "\\xlsx")
End If
MyFile = Dir(iPath & "\\*.xls")

If MyFile <> "" Then
Do
    On Error Resume Next
    If MyFile = ThisWorkbook.Name Then MyFile = Dir
    Workbooks.Open (iPath & "\\" & MyFile)
    MyFile = Replace(MyFile, ".xls", ".xlsx")
    Name = "\\" & MyFile
    FilePath = iPath & "\\xlsx" & Name
    Application.ScreenUpdating = False
    ActiveWorkbook.SaveAs Filename:=FilePath, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    Workbooks(MyFile).Close True
    Application.ScreenUpdating = True
    MyFile = Dir
Loop While MyFile <> ""
End If
End Sub

运行结束！