【典型案例】以家庭为单位拆分表格-技术圈

▎具体需求

ExcelVBA拆分工作簿是很常见的需求。Excel的拆分中有一类情况，不是按行数拆分，也不是按关键字拆分，而是按家庭单位拆分。如下图所示：

▎编写思路

既然是对家庭进行拆分，那么我们要找的就是户主这个关键字。两个户主所在的行，中间夹着的部分，就是单个家庭的所有数据。

首先，就是对C列进行循环，判断C列的值等于户主，当等于户主的时候，嵌套一个循环，找下一个户主所在的行。找到之后，就开始新建工作簿，把标题行和家庭的数据复制过去。

▎具体效果和代码

Sub 拆分()
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Application.AskToUpdateLinks = False
    Application.Calculation = xlManual
    Tm = Timer
    Dim newwb As Workbook
    '/新建文件夹，存放处理后的文件
    PathG = Environ("userprofile") & "\Desktop\拆分后\"
    MakeDir PathG
    '/
    With ThisWorkbook.ActiveSheet
        lrow = .Cells(.Rows.Count, 1).End(3).Row
        For i = 7 To lrow
            'If i > 100 Then Stop
            If .Cells(i, 3) = "户主" Then
                Set newwb = Workbooks.Add
                Set newsht = newwb.ActiveSheet
                ActiveWindow.Zoom = 50
                .Range("a1:y6").Copy newwb.ActiveSheet.Range("a1")
                newsht.Rows("7:100").RowHeight = 105
                For j = i + 1 To lrow + 1
                    If .Cells(j, 3) = "户主" Or .Cells(j, 3) = "" Then
                        '/复制数据行
                        .Range(.Cells(i, 1), .Cells(j - 1, "s")).Copy newwb.ActiveSheet.Range("a7")
                        '/
                        '/调整格式
                        newsht.Columns.AutoFit
                        newsht.Shapes("拆分按钮").Delete
                        '/保存工作簿，以人名和身份证号为文件名
                        newwb.SaveAs PathG & .Cells(i, 2).Value & .Cells(i, 4).Value & ".xls", 56
                        newwb.Close
                        Exit For
                    End If
                Next
                i = j - 1
            End If
        Next
    End With
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Application.AskToUpdateLinks = True
    Application.Calculation = xlAutomatic
    MsgBox "拆分完成，用时：" & Format(Timer - Tm, "0.00秒"), 64, "拆分报表"
End Sub
Function MakeDir(PathG)
'创建文件夹自定义函数，如果已存在，先删除再新建，如果不存在，直接新建。
    Set fso = CreateObject("Scripting.FileSystemObject")
    If fso.FolderExists(PathG) = True Then
        fso.getfolder(PathG).Delete '//删除文件夹
        MkDir PathG '//创建文件夹
    Else
        MkDir PathG '//创建文件夹
    End If
End Function

▎补充知识点

新建文件夹
拆分之后的文件，保存在桌面→拆分后文件夹中。因为代码可能会多次运行。所以，每次运行都要删除之前的拆分结果。

Function MakeDir(PathG)'创建文件夹自定义函数，如果已存在，先删除再新建，如果不存在，直接新建。    Set fso = CreateObject("Scripting.FileSystemObject")    If fso.FolderExists(PathG) = True Then        fso.getfolder(PathG).Delete '//删除文件夹        MkDir PathG '//创建文件夹    Else        MkDir PathG '//创建文件夹    End IfEnd Function

特殊文件夹路径

桌面路径： PathG = Environ("userprofile") & "\DeskTop\"

更多操作文件夹的知识可以看之前的文章《【代码合集】VBA操作文件夹代码合集》

本节附件获取方式，后台回复：家庭