下面是完美Excel社群中佳佳朋友的提问（我稍作整理）：
如下图1所示，根据是否是户主创建新工作表并将户主及对应的家庭成员复制到该工作表中，并以户主姓名命名该工作表。
图1
这种问题最适合使用VBA来解决。仔细观察后发现，户主对应的人数就是该户家庭在工作表中所占的行数，这样只要定位到户主，就知道了该户所有成员的范围，这就方便提取相应的数据了。VBA代码如下：
代码语言：javascript复制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又问：
如果没有人口数的话，如何实现？
很简单，只要有“户主”这个标志就行。下面的代码使用数组来存储户主所在行的行号以及该户所占的行数（也就是每户的人口数），其他的与上面的代码相同。
代码语言：javascript复制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
