社群答疑精选03：拆分数据到新工作表

下面是完美Excel社群中佳佳朋友的提问（我稍作整理）：

如下图1所示，根据是否是户主创建新工作表并将户主及对应的家庭成员复制到该工作表中，并以户主姓名命名该工作表。

图1

这种问题最适合使用VBA来解决。仔细观察后发现，户主对应的人数就是该户家庭在工作表中所占的行数，这样只要定位到户主，就知道了该户所有成员的范围，这就方便提取相应的数据了。VBA代码如下：

Sub test1()
    Dim lngLast As Long
    Dim str As String
    Dim rng As Range
    Dim rngData As Range
    Dim firstRng As String
    Dim wks As Worksheet
   
   '要查找的内容
    str = "户主"
   '工作表中最后一个数据所在行行号
    lngLast =Worksheets("Sheet1").Range("D" &Rows.Count).End(xlUp).Row
   '被查找的数据区域
    Set rngData =Worksheets("Sheet1").Range("D2:D" & lngLast)
   
   '查找第1个数据
    Set rng = rngData.Find(What:=str,LookIn:=xlValues)
   
   '如果找到
    If Not rng Is Nothing Then
        '获取第1个找到的数据的单元格地址
        firstRng = rng.Address
       
        '继续查找
        Do
            '如果工作表已存在
            If SheetExists(rng.Offset(0, -3))Then
                '屏蔽警告信息
                Application.DisplayAlerts =False
               '删除该工作表
                Worksheets(rng.Offset(0,-3).Value).Delete
                '新建工作表并以户主姓名命名
                Set wks =Worksheets.Add(After:=Sheets(Sheets.Count))
                wks.Name = rng.Offset(0, -3)
            Else
                '新建工作表并以户主姓名命名
                Set wks =Worksheets.Add(After:=Sheets(Sheets.Count))
                wks.Name = rng.Offset(0, -3)
            End If
            '复制相对应的数据到新工作表中
           Worksheets("Sheet1").Range("A" & rng.Row &":D" & rng.Row + rng.Offset(0, -1).Value - 1).Copy
           wks.Range("A1").PasteSpecial xlPasteAll
            '查找下一个数据
            Set rng =rngData.FindNext(After:=rng)
        Loop While Not rng Is Nothing Andrng.Address <> firstRng
    End If
   '恢复警告信息
    Application.DisplayAlerts = True
End Sub
 
'判断工作表是否存在
FunctionSheetExists(strName As String)
    On Error Resume Next
    SheetExists = CBool(Not Worksheets(strName)Is Nothing)
    On Error GoTo 0
End Function

又问：

如果没有人口数的话，如何实现？

很简单，只要有“户主”这个标志就行。下面的代码使用数组来存储户主所在行的行号以及该户所占的行数（也就是每户的人口数），其他的与上面的代码相同。

Sub test2()
    Dim lngLast As Long
    Dim str As String
    Dim rng As Range
    Dim rngData As Range
    Dim firstRng As String
    Dim wks As Worksheet
    Dim wksData As Worksheet
    Dim strName As String
    Dim arr1() As Long
    Dim arr2() As Long
    Dim i As Long
    Dim j As Long
    Dim k As Long
   
    i = 0
   '查找的内容
    str = "户主"
   '查找的数据所在的工作表
    Set wksData =Worksheets("Sheet1")
   '数据所在工作表的最后一行行号
    lngLast = wksData.Range("D" &Rows.Count).End(xlUp).Row
   '被查找的数据区域
    Set rngData =wksData.Range("D2:D" & lngLast)
   '重定义数组
    ReDim Preserve arr1(i)
   
   '查找数据,确保从开头查找
    Set rng = rngData.Find(What:=str,After:=wksData.Range("D" & lngLast), LookIn:=xlValues)
   
   '如果找到
    If Not rng Is Nothing Then
        '找到的第1个数据所在的单元格地址
        firstRng = rng.Address
        '继续查找
        Do
            '保存找到的数据所在的行号
            arr1(i) = rng.Row
            i = i + 1
            ReDim Preserve arr1(i)
            '查找下一个
            Set rng =rngData.FindNext(After:=rng)
        Loop While Not rng Is Nothing Andrng.Address <> firstRng
    End If
   
   '每户所占的行数
    For j = 0 To UBound(arr1) - 2
        ReDim Preserve arr2(j)
        arr2(j) = arr1(j + 1) - arr1(j)
    Next j
   
   '最后一户所占的行数
    ReDim Preserve arr2(j)
    arr2(j) = lngLast - arr1(j) + 1
   
   '新建工作表并复制户主数据到该工作表
    For k = 0 To UBound(arr2)
        strName = wksData.Range("A"& arr1(k))
        If SheetExists(strName) Then
            Application.DisplayAlerts = False
            Worksheets(strName).Delete
            Set wks =Worksheets.Add(After:=Sheets(Sheets.Count))
            wks.Name = strName
        Else
            wks.Name = strName
        End If
       
        wksData.Range("A" &arr1(k) & ":D" & arr1(k) + arr2(k) - 1).Copywks.Range("A1")
    Next k
    Application.DisplayAlerts = True
   
   '释放对象
    Set rng = Nothing
    Set rngData = Nothing
    Setwks = Nothing
End Sub
 
'判断工作表是否存在
FunctionSheetExists(strName As String)
    On Error Resume Next
    SheetExists = CBool(Not Worksheets(strName)Is Nothing)
    On Error GoTo 0
End Function

示例结果如下图2所示。

图2