急！求大神帮忙根据图1数据填入图2表格批量生成多个表格

看灰灰灰灰灰机

图1

图2

求大神帮忙根据图1数据按户主信息依次填入图2表格，家庭成员最多填入3个，不足3个的按实际情况填入，然后批量生成按户主姓名命名的多个表格，谢谢！！

abc123281

可以实现  但也很麻烦

看灰灰灰灰灰机

朱荣兴 发表于 2018-8-24 06:37
关键一点，得让代码知道每户的有哪些人？？？研究一下再说吧

好的，户主下面的就是，或者就填入户主下面一位救可

看灰灰灰灰灰机

abc123281 发表于 2018-8-24 00:53
可以实现  但也很麻烦

谢谢大神，那家庭情况就填入户主下面一位的话会不会更容易

魂断蓝桥

楼主参考一下吧。

注意放在单独的目录下，比如



代码会把各个组别分别建立文件夹。

因都需要建立单独文件，代码运行慢，别着急。

附件4：居民信息和需求调查表.rar (129.88 KB, 下载次数: 14)

2018-8-24 10:32 上传

点击文件名下载附件

Option Explicit
Sub a()
Dim cnn, rs As Object, Sql$, f$, arr, i%, j%, m%, k%, mb As Range, t%, R%
Set mb = Sheet2.[a1:h12]
Dim tim
tim = Timer
Set cnn = CreateObject("adodb.connection")
Set rs = CreateObject("adodb.Recordset")
Application.ScreenUpdating = False
cnn.Open "provider=microsoft.jet.oledb.4.0;extended properties=excel 8.0;data source=" & ThisWorkbook.FullName
Sql = "select  村小组 FROM [Sheet2$a2:b] where len(村小组)>1 group by 村小组 order by MIN(序号)"
arr = cnn.Execute(Sql).getrows
For i = 0 To UBound(arr, 2)
    f = ThisWorkbook.Path & "\" & arr(0, i)
        If Dir(f, vbDirectory) <> "" Then GoSub 100
            MkDir f
            Sql = "select * FROM [Sheet2$a2:i] where 村小组='" & arr(0, i) & "' order by 序号"
            If rs.State = 1 Then rs.Close
            rs.Open Sql, cnn, 1, 1
            m = rs.Fields("序号")
            rs.movelast
            k = rs.Fields("序号")
                For j = m To k
                    rs.Close
                    Sql = "select * FROM [Sheet2$a2:i] where  序号=" & j
                    rs.Open Sql, cnn, 1, 1
                    Workbooks.Add
                    t = t + 1
                    With ActiveWorkbook.Sheets(1)
                        mb.Copy .[a1]
                        .Columns("A:H").ColumnWidth = 10
                        .[h3] = t
                        .[c4] = rs.Fields("家庭成员（包户主）")
                        .[f4] = rs.Fields("性别")
                        .[h4] = rs.RecordCount
                        .[c5] = rs.Fields("身份证号码")
                        .[g5] = rs.Fields("联系电话")
                        .[d6] = arr(0, i)
                        If rs.RecordCount > 1 Then
                          .[G6] = "已婚"
                        Else
                            .[G6] = "未婚"
                        End If
                        rs.MoveNext
                        R = 9
                        Do While Not rs.EOF
                            R = R + 1
                            .Cells(R, 3) = rs.Fields("家庭成员（包户主）")
                            .Cells(R, 4) = rs.Fields("与户主关系")
                            .Cells(R, 5) = rs.Fields("身份证号码")
                            rs.MoveNext
                            If R > 12 Then Exit Do
                         Loop
                            If Dir(f & "\" & .[c4] & ".xls") = "" Then
                                ActiveWorkbook.SaveAs Filename:=f & "\" & .[c4] & ".xls", FileFormat:=xlWorkbookNormal
                                ActiveWorkbook.Close 1
                            Else
                                ActiveWorkbook.SaveAs Filename:=f & "\" & .[c4] & t & ".xls", FileFormat:=xlWorkbookNormal
                                ActiveWorkbook.Close 1
                            End If
                    End With
                Next
Next
       Exit Sub
100:
            On Error Resume Next
                Kill f & "\*.*"
            On Error GoTo 0
            RmDir f
            Return
cnn.Close
Set rs = Nothing
Set cnn = Nothing
Application.ScreenUpdating = True
MsgBox Format(Timer - tim, "0.00")
End Sub

魂断蓝桥

代码审核中，先上附件吧

1、放在单独目录下

2、会按照组别分别建立文件夹
3、代码运行慢，别着急

^顾弘^

你的本意应该是把汇总表里的信息，按家庭户分拆成表格吧。我用了5家不重复名字的试了一下，希望对你有用。



Sub 生成户()
Dim sht As Worksheet, sht2 As Worksheet, rng As Range, hus As Integer, rens As Integer
Set sht = Worksheets("汇总表")
For Each rng In sht.Range("c2:c2890")
Application.DisplayAlerts = False
If rng = "本人或户主" Then
    hus = hus + 1
    rens = rng.Offset(0, 5)
    Worksheets("模板").Copy after:=Worksheets(Worksheets.Count)
    ActiveSheet.Name = rng.Offset(0, 1)
    Set sht2 = ActiveSheet
With sht2
If rens >= 3 Then
    .Range("c4") = rng.Offset(0, 1)
    .Range("f4") = rng.Offset(0, 3)
    .Range("h4") = rng.Offset(0, 5)
    .Range("c5") = rng.Offset(0, 2)
    .Range("g5") = rng.Offset(0, 6)
    .Range("c6") = rng.Offset(0, -1)
    .Range("c9") = rng.Offset(1, 1)
    .Range("d9") = rng.Offset(1, 0)
    .Range("e9") = rng.Offset(1, 2)
    .Range("c10") = rng.Offset(2, 1)
    .Range("d10") = rng.Offset(2, 0)
    .Range("e10") = rng.Offset(2, 2)
    .Range("h3") = hus
ElseIf rens = 2 Then
    .Range("c4") = rng.Offset(0, 1)
    .Range("f4") = rng.Offset(0, 3)
    .Range("h4") = rng.Offset(0, 5)
    .Range("c5") = rng.Offset(0, 2)
    .Range("g5") = rng.Offset(0, 6)
    .Range("c6") = rng.Offset(0, -1)
    .Range("c9") = rng.Offset(1, 1)
    .Range("d9") = rng.Offset(1, 0)
    .Range("e9") = rng.Offset(1, 2)
    .Range("c10") = ""
    .Range("d10") = ""
    .Range("e10") = ""
    .Range("h3") = hus
ElseIf rens = 1 Then
    .Range("c4") = rng.Offset(0, 1)
    .Range("f4") = rng.Offset(0, 3)
    .Range("h4") = rng.Offset(0, 5)
    .Range("c5") = rng.Offset(0, 2)
    .Range("g5") = rng.Offset(0, 6)
    .Range("c6") = rng.Offset(0, -1)
    .Range("c9") = ""
    .Range("d9") = ""
    .Range("e9") = ""
    .Range("c10") = ""
    .Range("d10") = ""
    .Range("e10") = ""
    .Range("h3") = hus
End If
End With
sht2.Copy
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & hus & sht2.Name & ".xlsx"
ActiveWorkbook.Close
sht2.Delete
End If
Next
Application.DisplayAlerts = True
End Sub

看灰灰灰灰灰机

魂断蓝桥 发表于 2018-8-24 10:33
代码审核中，先上附件吧

1、放在单独目录下

太厉害了，谢谢大神！