如何以户为单位生成独立表格文件

testwps

共有两个表格，一个是上图中的数据表，是户内信息，可以按照户主或户号区分户内成员。
下图是要填写的表格，把数据表户成员信息填入到登记表中并以户主姓名进行保存，每户单独一个文件。


本人是小白，不会VBA，研究了一天也完全没明白，求大神帮忙。

参考了一位大神给别人的回贴，已解决，附解决代码

1. Sub dengji()
   
2.     Dim arr, brr, frr(), S$, S1$, mt, mh
   
3.     Application.ScreenUpdating = False
   
4.     Application.DisplayAlerts = False
   
5.     Set wb = Workbooks.Open(ThisWorkbook.Path & "\数据\数据.xls")
   
6.     brr = Range(("b2"), Cells(Rows.Count, 2).End(xlUp))
   
7.     arr = Range("a2").Resize(Cells(Rows.Count, 1).End(xlUp).Row - 1, 8)
   
8.     wb.Close False
   
9.     S = Join(Application.Transpose(brr), vbTab) & vbTab
   
10.     With CreateObject("VBScript.Regexp")
    
11.         .Global = True
    
12.         .Pattern = "^.*户主.*$"
    
13.         For i = 1 To UBound(arr)
    
14.             If .test(arr(i, 2)) = True Then
    
15.                 n = n + 1
    
16.                 ReDim Preserve frr(1 To n)
    
17.                 frr(n) = arr(i, 1) & arr(i, 4) & arr(i, 3)
    
18.             End If
    
19.         Next
    
20.         .Pattern = "户主(?:(?!户主).*?\t)+"
    
21.         For Each mt In .Execute(S)
    
22.             k = k + 1: S1 = mt
    
23.             Sheet1.Copy
    
24.             .Pattern = ".*?\t"
    
25.             x = 0: y = 0
    
26.             For Each mh In .Execute(S1)
    
27.                 j = j + 1: x = x + 1: y = y + 1
    
28.                 If y = 1 Then
    
29.                     Cells(x + 3, 2) = arr(j, 1)
    
30.                     Cells(x + 3, 3) = arr(j, 2)
    
31.                     Cells(x + 3, 4) = arr(j, 3)
    
32.                     Cells(x + 3, 5) = arr(j, 4)
    
33.                     Cells(x + 3, 6) = arr(j, 5)
    
34.                     Cells(x + 3, 7) = arr(j, 6)
    
35.                     Cells(x + 3, 8) = arr(j, 7)
    
36.                     Cells(x + 3, 9) = arr(j, 8)
    
37.                 Else
    
38.                     Cells(x + 3, 2) = arr(j, 1)
    
39.                     Cells(x + 3, 3) = arr(j, 2)
    
40.                     Cells(x + 3, 4) = arr(j, 3)
    
41.                     Cells(x + 3, 5) = arr(j, 4)
    
42.                     Cells(x + 3, 6) = arr(j, 5)
    
43.                     Cells(x + 3, 7) = arr(j, 6)
    
44.                     Cells(x + 3, 8) = arr(j, 7)
    
45.                     Cells(x + 3, 9) = arr(j, 8)
    
46.                 End If
    
47.             Next
    
48.             ActiveWorkbook.SaveAs ThisWorkbook.Path & "\登记表" & frr(k) & ".xlsx"
    
49.             ActiveWorkbook.Close
    
50.         Next
    
51.     End With
    
52.     Application.DisplayAlerts = True
    
53.     Application.ScreenUpdating = True
    
54. End Sub
    

复制代码

sunshuangzhong

个人理解：这个题目感觉就是以户号这一列拆分成不同文件而已！

liulang0808

Sub 按钮1_Click()
    arr = Sheets("数据").UsedRange
    Set sh = Sheets("模板")
    Set wb = Nothing
    Application.ScreenUpdating = False
    For j = 2 To UBound(arr)
        If arr(j, 2) = "户主" Then
            r = 4
            If Not wb Is Nothing Then
                wb.SaveAs ThisWorkbook.Path & "\" & wb.Sheets(1).[b4] & ".xlsx"
                wb.Close
            End If
            sh.Copy
            Set wb = ActiveWorkbook
            For i = 1 To 8
                wb.Sheets(1).Cells(r, i + 1) = arr(j, i)
            Next i
        Else
            r = r + 1
            For i = 1 To 8
                wb.Sheets(1).Cells(r, i + 1) = arr(j, i)
            Next i
        End If
    Next j
    wb.SaveAs ThisWorkbook.Path & "\" & wb.Sheets(1).[b4] & ".xlsx"
    wb.Close
    Application.ScreenUpdating = True
End Sub

liulang0808

供参考。。。。。。

gwjkkkkk

请楼主参考。。。

gwjkkkkk

请参考附件。。。

chengyunpan

万能批量打印，用于楼主的案例。

testwps

chengyunpan 发表于 2022-11-2 21:37
万能批量打印，用于楼主的案例。

一个比一个强大，学习了，感谢

testwps

liulang0808 发表于 2022-10-26 08:18
Sub 按钮1_Click()
    arr = Sheets("数据").UsedRange
    Set sh = Sheets("模板")

简洁明了，非常感谢

chengyunpan

testwps 发表于 2022-11-23 10:11
一个比一个强大，学习了，感谢

可以加我，你也可以学会万能套用。