需要从“数据源表”提取数据到“家庭收入采集表”，要求每户建一张家庭收入采集表...

刘海伟lhw

需要从“数据源表”提取数据到“家庭收入采集表”，要求每户建一张家庭收入采集表，每户下面有多人，同时提取家庭成员个人信息和家庭收入。跪求大神帮助解决，本人不会VBA。

andysky

视频教材：
https://mp.weixin.qq.com/s/FbeYUUat6DSRO3jwg3-YAQ
和你的需求一样，点几下就完成了。

andysky

这就是你要的效果
一模一样
首次使用时要设置参数，以后都是一键完成
E灵，咦？灵！

3190496160

Sub 批量()
Application.ScreenUpdating = False
Dim ar As Variant
Dim arr()
Application.DisplayAlerts = False
For Each sh In Sheets
    If sh.Index > 2 Then
        sh.Delete
    End If
Next sh
Application.DisplayAlerts = True
ar = Sheets("数据源").[a1].CurrentRegion
For i = 2 To UBound(ar)
    If Trim(ar(i, 5)) = "户主" Then
        hs = ar(i, 10)
        n = 0
        ReDim arr(1 To hs, 1 To 9)
        For s = i To i + hs - 1
            n = n + 1
            arr(n, 1) = n
            arr(n, 2) = ar(i, 1)
            arr(n, 3) = ar(i, 4)
            arr(n, 4) = ar(i, 2)
            arr(n, 5) = ar(i, 5)
            arr(n, 6) = ar(i, 7)
            arr(n, 7) = ar(i, 8)
            arr(n, 9) = ar(i, 9)
        Next s
        Sheets("家庭收入采集表").Copy after:=Sheets(Sheets.Count)
        With Sheets(Sheets.Count)
            .Name = ar(i, 1) & "_" & ar(i, 2)
            .[a3].Resize(n, UBound(arr, 2)) = arr
            .[b10] = ar(i, 11)
            .[d10] = ar(i, 12)
            .[f10] = ar(i, 13)
            .[h10] = ar(i, 14)
            .[j10] = ar(i, 15)
        End With
    End If
Next i
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

求助工作表.rar (27.55 KB, 下载次数: 13)

2022-4-20 09:24 上传

点击文件名下载附件

123-456789

这种问题，用word中的邮件合并处理起来比较方便。

刘海伟lhw

123-456789 发表于 2022-4-22 15:58
这种问题，用word中的邮件合并处理起来比较方便。

我不会邮件合并一对多啊，如何解决？

刘海伟lhw

请问有没有免费工具可以使用啊，E灵免费版只能导出20个表

andysky

刘海伟lhw 发表于 2022-4-27 13:04
请问有没有免费工具可以使用啊，E灵免费版只能导出20个表

自己开发的就免费
不过这种免费的 比收费的成本还要高
学好VBA开发，成本是上万元
假设学编程一年，利用业余时间每天两小时，一天算50元，一年就是1.5万，时间成本。




要么费时间，要么费点钱。
                          ---鲁迅