求助用宏批量提取数据自动填表VBA代码错误问题

wcc123

非常感谢“chxw68”大大、褚老师和各位大神的帮忙！！！
        在论坛诸位大神的帮助下，编写了一个test宏，实现了利用”模板表“，批量从各个明细表（如：”工资性收入“、“生产经营性收支”“转移性收入”等工作表）中，自动提取数据批量填写生成新表的功能，代码很顺畅，运行了一段时间也未发现问题。
       但是，现在遇到一种特殊情况：当某户（如：孔思荣户）当年无工资性收入时（即”工资性收入“表中该户全年无数据），但有“生产经营性收支”等其他数据时，则自动填写生成的新表会缺少该户（如：样例中有五户人，孔思荣户当年无工资性收入，但自动填写后，生成的新表却只有4户，缺了“孔思荣”户），不知VBA代码错在哪，请诸位大神帮助修改完善代码，不吝指教，谢谢！

shiruiqiang

因为你以d.keys的字典分表，上述所在名单没有在第一张表(而d.key是以第一张表创建)

wcc123

shiruiqiang 发表于 2024-8-6 06:50
因为你以d.keys的字典分表，上述所在名单没有在第一张表(而d.key是以第一张表创建)

@shiruiqiang大大，实际中有可能遇到某户当年无“工资性收入”数据或无“生产经营收支”（也就是说“因为你以d.keys的字典分表，上述所在名单没有在第一张表(而d.key是以第一张表创建)”，d.key以第一张表或第二张表创建都可能会缺户，像这样的情况，不知test宏代码要如何设计修改，请大大们帮忙，多谢！

3190496160

赵原作者帮你解决吧，这么多代码，别人要看懂再帮你修改，几乎是不可能的

longwin

源代码基础上改了一下，测试通过：
Sub test()
    Dim r%, i%
    Dim arr, brr
    Dim d As Object
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set d = CreateObject("scripting.dictionary")
    Set d0 = CreateObject("scripting.dictionary")
    Set d1 = CreateObject("scripting.dictionary")
    Set d2 = CreateObject("scripting.dictionary")
    With Worksheets("户信息")
        r = .Cells(.Rows.Count, 1).End(xlUp).Row
        arr = .Range("a4:l" & r)
        For i = 1 To UBound(arr)
            If Not d0.exists(arr(i, 6)) Then
                Set d0(arr(i, 6)) = CreateObject("scripting.dictionary")
            End If
            If arr(i, 11) = "户主" Then
                d0(arr(i, 6))(0) = Array(arr(i, 3), arr(i, 4), arr(i, 5), arr(i, 8), arr(i, 6), arr(i, 9))
            End If
            d0(arr(i, 6))(arr(i, 8)) = arr(i, 11)
        Next
    End With
    With Worksheets("工资性收入")
        r = .Cells(.Rows.Count, 1).End(xlUp).Row
        arr = .Range("a3:y" & r)
        For i = 1 To UBound(arr)
            jd = Val(arr(i, 11))
            If Not d.exists(arr(i, 6)) Then
                Set d(arr(i, 6)) = CreateObject("scripting.dictionary")
            End If
            If Not d(arr(i, 6)).exists(arr(i, 13)) Then
                ReDim brr(1 To 29)
                brr(1) = arr(i, 13)
                If d0.exists(arr(i, 6)) Then
                    If d0(arr(i, 6)).exists(arr(i, 13)) Then
                        brr(2) = d0(arr(i, 6))(arr(i, 13))
                    End If
                End If
                brr(3) = DateDiff("yyyy", CDate(Format(Mid(arr(i, 14), 7, 8), "0000-00-00")), Date)
            Else
                brr = d(arr(i, 6))(arr(i, 13))
            End If
            If jd = 1 Then
                brr(4) = arr(i, 16) & arr(i, 17) & arr(i, 18) & arr(i, 19) & arr(i, 20)
                brr(5) = arr(i, 21)
                brr(6) = arr(i, 22)
                brr(7) = DateDiff("d", arr(i, 23), arr(i, 24))
                brr(8) = arr(i, 25)
            Else
                n = jd * 7 - 5
                brr(n) = arr(i, 16) & arr(i, 17) & arr(i, 18) & arr(i, 19) & arr(i, 20)
                brr(n + 3) = arr(i, 21)
                brr(n + 4) = arr(i, 22)
                brr(n + 5) = DateDiff("d", arr(i, 23), arr(i, 24))
                brr(n + 6) = arr(i, 25)
            End If
            d(arr(i, 6))(arr(i, 13)) = brr
        Next
    End With
    With Worksheets("生产经营性收支")
        r = .Cells(.Rows.Count, 1).End(xlUp).Row
        arr = .Range("a3:p" & r)
    End With
    For i = 1 To UBound(arr)
        jd = Val(arr(i, 11))
        If Not d1.exists(arr(i, 6)) Then
            Set d1(arr(i, 6)) = CreateObject("scripting.dictionary")
        End If
        If Not d1(arr(i, 6)).exists(jd) Then
            Set d1(arr(i, 6))(jd) = CreateObject("scripting.dictionary")
        End If
        Select Case arr(i, 13)
            Case "种植业", "林果业", "养殖业"
                If Not d1(arr(i, 6))(jd).exists(arr(i, 13)) Then
                    Set d1(arr(i, 6))(jd)(arr(i, 13)) = CreateObject("scripting.dictionary")
                End If
                If Not d1(arr(i, 6))(jd)(arr(i, 13)).exists(arr(i, 14)) Then
                    ReDim crr(1 To 3, 1 To 1)
                    crr(1, 1) = arr(i, 14)
                Else
                    crr = d1(arr(i, 6))(jd)(arr(i, 13))(arr(i, 14))
                End If
                If Right(arr(i, 12), 2) = "收入" Then
                    crr(2, 1) = crr(2, 1) + Val(arr(i, 16))
                Else
                    crr(3, 1) = crr(3, 1) + Val(arr(i, 16))
                End If
                d1(arr(i, 6))(jd)(arr(i, 13))(arr(i, 14)) = crr
            Case "加工业", "乡村旅游业"
                If Not d1(arr(i, 6))(jd).exists(arr(i, 13)) Then
                    Set d1(arr(i, 6))(jd)(arr(i, 13)) = CreateObject("scripting.dictionary")
                End If
                xm = Right(arr(i, 12), 2)
                d1(arr(i, 6))(jd)(arr(i, 13))(xm) = d1(arr(i, 6))(jd)(arr(i, 13))(xm) + arr(i, 16)
            Case Else
                Debug.Print arr(i, 13)
        End Select
    Next
    With Worksheets("转移性收入")
        r = .Cells(.Rows.Count, 1).End(xlUp).Row
        arr = .Range("a3:p" & r)
    End With
    For i = 1 To UBound(arr)
        jd = Val(arr(i, 11))
        If Not d2.exists(arr(i, 6)) Then
            Set d2(arr(i, 6)) = CreateObject("scripting.dictionary")
        End If
        If Not d2(arr(i, 6)).exists(jd) Then
            Set d2(arr(i, 6))(jd) = CreateObject("scripting.dictionary")
        End If
        If InStr(arr(i, 13), ">") = 0 Then
            xx = arr(i, 13)
        Else
            xx = Mid(arr(i, 13), InStrRev(arr(i, 13), ">") + 1)
        End If
        d2(arr(i, 6))(jd)(xx) = d2(arr(i, 6))(jd)(xx) + Val(arr(i, 16))
    Next
    Set dz = CreateObject("scripting.dictionary")
    For Each aa In d.keys
    dz(aa) = 1
    Next
    For Each aa In d0.keys
    dz(aa) = 1
    Next
    For Each aa In d1.keys
    dz(aa) = 1
    Next
    For Each aa In d2.keys
    dz(aa) = 1
    Next
    With Worksheets("模板表")
        For Each aa In dz.keys
            On Error Resume Next
            Worksheets(aa).Delete
            On Error GoTo 0
            .Range("c2,f2,i2,l2,p2,t2,z2,a6:ac9,c12:e26,j12:l26,q12:s26,x12:z26,b28:h29,j28:o29,q28:v29,x28:ac29") = Empty
            .Range("f12,g12,m12,n12,t12,u12,aa12,ab12") = "收入：" & Application.Rept(vbLf, 5) & "支出："
            .Range("h12,o12,v12,ac12") = "种类1：" & Application.Rept(vbLf, 4) & "收入1：" & Application.Rept(vbLf, 4) & "支出1：" & Application.Rept(vbLf, 4) & "种类2：" & Application.Rept(vbLf, 4) & "收入2：" & Application.Rept(vbLf, 4) & "支出2："
            drr = d0(aa)(0)
            If d.exists(aa) Then
            ReDim crr(1 To d(aa).Count, 1 To 29)
            m = 0
            For Each bb In d(aa).keys
                If bb <> 0 Then
                    brr = d(aa)(bb)
                    m = m + 1
                    For j = 1 To UBound(brr)
                        crr(m, j) = brr(j)
                    Next
                End If
            Next
            .Range("c2") = drr(0)
            .Range("f2") = drr(1)
            .Range("i2") = drr(2)
            .Range("p2") = drr(3)
            .Range("t2") = drr(4)
            .Range("z2") = drr(5)
            .Range("a6").Resize(UBound(crr), UBound(crr, 2)) = crr
            End If
            
            If d1.exists(aa) Then
                For Each bb In d1(aa).keys
                    n = bb * 7 - 5
                    y = 0
                    For Each cc In Array("种植业", "林果业", "养殖业")
                        y = y + 1
                        If d1(aa)(bb).exists(cc) Then
                            m = 12
                            For Each dd In d1(aa)(bb)(cc).keys
                                crr = d1(aa)(bb)(cc)(dd)
                                .Cells(m, n + y).Resize(UBound(crr), UBound(crr, 2)) = crr
                                m = m + 3
                            Next
                        End If
                    Next
                    y = 0
                    For Each cc In Array("加工业", "乡村旅游业")
                        y = y + 1
                        If d1(aa)(bb).exists(cc) Then
                            .Cells(12, n + y + 3) = "收入：" & vbLf & IIf(d1(aa)(bb)(cc).exists("收入"), d1(aa)(bb)(cc)("收入") & vbLf, vbLf) & "支出：" & vbLf & IIf(d1(aa)(bb)(cc).exists("支出"), d1(aa)(bb)(cc)("支出"), "")
                        End If
                    Next
                Next
            End If
            
            If d2.exists(aa) Then
                For Each bb In d2(aa).keys
                    n = Application.Choose(bb, 2, 10, 17, 24)
                    ReDim frr(1 To 2, 1 To d2(aa)(bb).Count)
                    y = 0
                    For Each cc In d2(aa)(bb).keys
                        y = y + 1
                        frr(1, y) = cc
                        frr(2, y) = d2(aa)(bb)(cc)
                    Next
                    .Cells(28, n).Resize(UBound(frr), UBound(frr, 2)) = frr
                Next
            End If
            
            shtname = drr(3)
            On Error Resume Next
            Worksheets(shtname).Delete
            On Error GoTo 0
            .Copy after:=Worksheets(Worksheets.Count)
            With ActiveSheet
                .Name = shtname
            End With
        Next
    End With
End Sub

longwin

请参考附件....

wcc123

longwin 发表于 2024-8-6 11:19
请参考附件....

源代码经过longwin大大帮助修改，已不会再出现缺户少户的情况了，谢谢longwin大大和坛内诸位大神的帮忙！！！

h2016

留下脚印看看