[已解决]万能的VBA、实现根据身份证号统计家庭户数报表

yjwdjfqb · 发表于 2015-2-1 19:22

万能的VBA、实现根据身份证号统计家庭户数报表
我一个朋友在居委会上班，找我帮做个这样的统计表报表。
感觉好难，请各位高手老师帮帮忙，谢谢大家了！
附件中做了手工表！
如图：
效果图.jpg

VBA根据身份证号统计户数报表.rar (8.4 KB, 下载次数: 19)

yjwdjfqb · 发表于 2015-2-1 19:52

请大师们帮帮忙，谢谢大家了！

dsmch · 发表于 2015-2-2 05:22

Sub Macro1()
Dim arr, brr, d, i&, j%, s&, k%, rng As Range
Set d = CreateObject("scripting.dictionary")
arr = Sheets("数据源").Range("a1").CurrentRegion
ReDim brr(1 To UBound(arr), 1 To 11)
For i = 2 To UBound(arr)
If arr(i, 8) = "本人" Then d(arr(i, 4)) = i
Next
For i = 2 To UBound(arr)
If arr(i, 8) <> "本人" And d.exists(arr(i, 8)) Then d(arr(i, 8)) = d(arr(i, 8)) & " " & i
Next
a = d.keys: b = d.items
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Range("a2:k60000").Clear
With [a:k]
.NumberFormatLocal = "@"
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
For i = 0 To d.Count - 1
x = Split(b(i))
For j = 0 To UBound(x)
s = s + 1: n = x(j)
brr(s, 1) = i + 1
If j = 0 Then
Cells(s + 1, 1).Resize(UBound(x) + 1).Merge
If rng Is Nothing Then
Set rng = Cells(s + 1, 4)
Else
Set rng = Union(rng, Cells(s + 1, 4))
End If
End If
If j = 1 Then Cells(s + 1, 2).Resize(UBound(x)).Merge
brr(s, 2) = IIf(j = 0, "户主", "成员")
brr(s, 3) = j + 1
For k = 2 To 9
brr(s, k + 2) = arr(n, k)
Next
Next
Next
Range("a2").Resize(s, 11) = brr
If Not rng Is Nothing Then
rng.Font.ColorIndex = 3
rng.Font.Bold = True
End If
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

复制代码

dsmch · 发表于 2015-2-2 05:26

………………

yjwdjfqb · 发表于 2015-2-3 11:41

dsmch 发表于 2015-2-2 05:26
………………

老师你好，感谢你的帮助，非常好用。

可以再麻烦老师帮我加下每句的注释吗，谢谢你了老师！

dsmch · 发表于 2015-2-3 12:29

程序解释器
http://www.excelpx.com/forum.php ... 2%BD%E2%CA%CD%C6%F7

yjwdjfqb · 发表于 2015-2-3 13:17

dsmch 发表于 2015-2-3 12:29
程序解释器
http://www.excelpx.com/forum.php?mod=viewthread&tid=186721&highlight=%B3%CC%D0%F2%BD%E2% ...

老师你好，我用了这个

但，还是好多语句看不懂，麻烦老师空的时候，帮我加下好吗，谢谢你了老师！

dsmch · 发表于 2015-2-3 13:38

Sub Macro1()
Dim arr, brr, d, i&, j%, s&, k%, rng As Range
'声明字典对象
Set d = CreateObject("scripting.dictionary")
'源数据数据放入数组arr
arr = Sheets("数据源").Range("a1").CurrentRegion
'结果放入数组brr，首先找出户主，因为源数据较乱，有时是家庭成员在前
ReDim brr(1 To UBound(arr), 1 To 11)
'循环数组arr,
For i = 2 To UBound(arr)
If arr(i, 8) = "本人" Then d(arr(i, 4)) = i
Next
'把和户主身份证相同的行放在同一条目
For i = 2 To UBound(arr)
If arr(i, 8) <> "本人" And d.exists(arr(i, 8)) Then d(arr(i, 8)) = d(arr(i, 8)) & " " & i
Next
a = d.keys: b = d.items
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'清空单元格并设置单元格格式
Range("a2:k60000").Clear
With [a:k]
.NumberFormatLocal = "@"
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
'按户主循环，户主和成员归队
For i = 0 To d.Count - 1
'条目分列，具体到每个家庭成员所在的行
x = Split(b(i))
For j = 0 To UBound(x)
s = s + 1: n = x(j)
brr(s, 1) = i + 1 '户数序号
If j = 0 Then
'分别按每户人数合并单元格
Cells(s + 1, 1).Resize(UBound(x) + 1).Merge
'把户主所在的单元格放入rng ,方便统一设置格式
If rng Is Nothing Then
Set rng = Cells(s + 1, 4)
Else
Set rng = Union(rng, Cells(s + 1, 4))
End If
End If
If j = 1 Then Cells(s + 1, 2).Resize(UBound(x)).Merge
brr(s, 2) = IIf(j = 0, "户主", "成员") '家庭关系
brr(s, 3) = j + 1 '家庭人员序号
'按数组arr对应的行放进数组brr
For k = 2 To 9
brr(s, k + 2) = arr(n, k)
Next
Next
Next
'填充结果
Range("a2").Resize(s, 11) = brr
'设置户主所在的单元格字体格式
If Not rng Is Nothing Then
rng.Font.ColorIndex = 3
rng.Font.Bold = True
End If
'设置边框
Range("a1").CurrentRegion.Borders.LineStyle = 1
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

复制代码

yjwdjfqb · 发表于 2016-6-20 10:30

dsmch 发表于 2015-2-3 13:38

老师你好，今天我在用这个实例，进行统计时，增加了些项目。
我修改了下，结果没有正确
我在“原数据中，增加了些项目，就是备注一到三十”，想在统计的时候，也能在统计表中，统计显示出来，请老师帮帮忙，谢谢你了老师！

VBA根据身份证号的唯一性来统计每个户主的家庭成员.rar (123.56 KB, 下载次数: 13)

yjwdjfqb · 发表于 2016-12-11 22:43

dsmch 发表于 2015-2-3 13:38

老师你好，最近在录入精准扶贫名册时，想起老师帮我的这个文件
是去年做的
但在用的时候，要增加些统计项目，不会做，请老师帮我加下好吧，谢谢你了老师！

VBA根据身份证号的唯一性生成统计表.rar (38.81 KB, 下载次数: 5)

		自动登录	找回密码
密码			注册

[已解决]万能的VBA、实现根据身份证号统计家庭户数报表

相关帖子

评分