我有1000户居民信息，如何按户分解成一户一户的？

lover826 · 发表于 2022-5-26 17:51

您好，请教一下，我有1000户居民信息，如何以户主名字+身份证号码按户分解成一户一户的？然后批量打印，请师傅帮忙详细教一下，谢谢！不胜感激

要求：(表格名：居民信息.xlsx)
1、第一种是sheet1就是居民信息总表，在同一个工作簿内，以同样格式，以“户主名字+身份证号码”为工作表名生成该户信息。
2、以“户主名字+身份证号码”为工作表名，以同样格式，逐户分解成成单个表格文档存到文件夹。
表1.png

居民信息.rar (8.82 KB, 下载次数: 34)

webber04 · 发表于 2022-5-26 19:09

VBA范畴问题

3190496160 · 发表于 2022-5-26 20:29

Sub 拆分为工作簿()
Application.ScreenUpdating = False
Dim ar As Variant, br As Variant
Dim i As Long
Dim arr()
Dim d As Object
Dim sh As Worksheet
Dim rng As Range
Set sh = ThisWorkbook.ActiveSheet
Set d = CreateObject("scripting.dictionary")
With sh
r = .Cells(Rows.Count, 1).End(xlUp).Row
ar = .Range("a1:h" & r)
End With
For i = 2 To UBound(ar)
If Trim(ar(i, 1)) <> "" Then
      d(Trim(ar(i, 1))) = ""
End If
Next i
For Each k In d.keys
sh.Copy
Set wb = ActiveWorkbook
With wb.Worksheets(1)
      For i = 2 To UBound(ar)
         If Trim(.Cells(i, 1)) <> k Then
            If rng Is Nothing Then
                  Set rng = .Rows(i)
            Else
                  Set rng = Union(rng, .Rows(i))
            End If
         End If
      Next i
      For Each sp In .Shapes
         sp.Delete
      Next sp
      If Not rng Is Nothing Then rng.Delete
      rs = .Cells(Rows.Count, 1).End(xlUp).Row
      For i = 2 To rs
         If Trim(.Cells(i, 5)) = "户主" Then
            xh = i
            Exit For
         End If
      Next i
      mc = .Cells(xh, 2) & "-" & .Cells(xh, 3)
End With

Set rng = Nothing
wb.SaveAs Filename:=ThisWorkbook.Path & "\" & mc & ".xlsx"
wb.Close
Next k
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160 · 发表于 2022-5-26 20:30

拆分.rar (19.56 KB, 下载次数: 23)

kuangben8 · 发表于 2022-5-26 20:47

Dim dic As Object
Sub 分解成表()
Dim dd
Application.ScreenUpdating = False
Call 删除工作表
Call 提取分类
With ThisWorkbook
For Each dd In dic.Keys
With .Worksheets.Add(After:=Worksheets(Sheets.Count))
.Name = dd
dic.Item(dd).Copy .Range("A1")
.Columns("A:Z").EntireColumn.AutoFit
End With
Next
.Worksheets("Sheet1").Activate
End With
Set dic = Nothing
Application.ScreenUpdating = True
End Sub
Sub 分解成簿()
Dim dd, wBook As Workbook
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Call 提取分类
Application.SheetsInNewWorkbook = 1
For Each dd In dic.Keys
Set wBook = Workbooks.Add '新建工作簿
With wBook
With .Worksheets(1)
.Name = dd
dic(dd).Copy .Range("A1") '此处直接复制、粘贴带有单元格格式的数据。
.Columns("A:Z").EntireColumn.AutoFit
End With
.SaveAs Filename:=ThisWorkbook.Path & "" & dd
.Close False
End With
Next
Set dic = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Function 删除工作表()
Dim Sht As Worksheet
Application.DisplayAlerts = False
For Each Sht In ThisWorkbook.Worksheets
If Sht.Name <> "Sheet1" Then
Sht.Delete
End If
Next
Application.DisplayAlerts = True
End Function
Function 提取分类()
Dim arr, m%, n%, Str$
Set dic = CreateObject("Scripting.Dictionary")
arr = Sheet1.Range("A1").CurrentRegion
With Worksheets("Sheet1")
For m = 2 To UBound(arr, 1)
If arr(m, 5) = "户主" Then
Str = arr(m, 2) & "+" & arr(m, 3)
'If Not dic.Exists(Str) Then
Set dic(Str) = .Range(.Cells(1, 1), .Cells(1, UBound(arr, 2)))
Set dic(Str) = Union(dic(Str), .Range(.Cells(m, 1), .Cells(m, UBound(arr, 2))))
'End If
Else
Set dic(Str) = Union(dic(Str), .Range(.Cells(m, 1), .Cells(m, UBound(arr, 2))))
End If
Next
End With
End Function

复制代码

kuangben8 · 发表于 2022-5-26 20:48

代码审核中，参考附件

居民信息分解.zip (65.26 KB, 下载次数: 19)

lgcmeli · 发表于 2022-6-1 13:04

想办法用筛选法编制vba，效率更高

hbsdtjz · 发表于 2022-6-4 11:52

如果是拆分，用楼上的VBA。如果仅仅是分别打印，可以跟word结合用邮件合并更简单。

andysky · 发表于 2022-6-4 14:07

https://mp.weixin.qq.com/s/FbeYUUat6DSRO3jwg3-YAQ

这里有一个通用版本，支持任何格式的，不需要格式变化后重写代码。

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

[求助] 我有1000户居民信息，如何按户分解成一户一户的？

评分

评分