拆分工作簿为多个文件_VBA拆分任意列为表、工作簿

微信搜一搜 XData Analysis

模板：

原始表如上，例如我想安装行政区拆分为多个sheet

vba实现：

 文件以及代码如下：

链接：https://pan.baidu.com/s/1LWashyX9drpGiDX8QJuhdw
提取码：5suv
 另外一种情况，拆分到工作簿，直接用下面代码：当前是拆分B列，自行修改下就行

        拆分列数组 = .Range("b1:b" & 行数)

改成自己要拆分的列

Sub 根据B列_拆分成工作薄()    Set 字典 = CreateObject("scripting.dictionary")    Application.ScreenUpdating = False: Application.DisplayAlerts = False    With Worksheets("sheet1")        行数 = .Cells(.Rows.Count, 1).End(xlUp).Row        列数 = .Cells(2, .Columns.Count).End(xlToLeft).Column        ReDim 表头加标题行数组(1 To 3)        For 非数据行 = 1 To 3            表头加标题行数组(非数据行) = .Rows(非数据行).RowHeight        Next 非数据行        ReDim 列数数组(1 To 列数)        For 列 = 1 To 列数            列数数组(列) = .Columns(列).ColumnWidth        Next 列        拆分列数组 = .Range("b1:b" & 行数)        For 行 = 4 To UBound(拆分列数组)            If Not 字典.exists(拆分列数组(行, 1)) Then                Set 字典(拆分列数组(行, 1)) = .Range("a1:k3")            End If            Set 字典(拆分列数组(行, 1)) = Union(字典(拆分列数组(行, 1)), .Cells(行, 1).Resize(1, 11))        Next 行    End With    Application.SheetsInNewWorkbook = 1    For Each 关键字 In 字典.keys        Set 新生薄 = Workbooks.Add        With 新生薄            With .Worksheets(1)                字典(关键字).Copy .Range("a1")                行数 = .Cells(.Rows.Count, 1).End(xlUp).Row                .Range("g3:k3").FormulaR1C1 = "=SUM(R4C:R" & 行数 & "C)"                For i = 1 To 2                    .Rows(i).RowHeight = 表头加标题行数组(i)                Next i                .Rows("3:" & 行数).RowHeight = 表头加标题行数组(3)                For 列 = 1 To 列数                    .Columns(列).ColumnWidth = 列数数组(列)                Next 列            End With            .SaveAs Filename:=ThisWorkbook.Path & "/" & 关键字            .Close False        End With    Next 关键字    Application.ScreenUpdating = True    MsgBox "数据拆分完毕！"End Sub

‍扫码加入小白编程，共同成长！