跪求大佬帮忙，谢谢！根据模板将汇总数据批量生成新表

wuqing960412

根据归户确认表【】内的文字，读取数据表的内容。

按照数据文件名名生成一个个归户确认表表格

剑指E

引用网友的话：
这是一体力活！

limonet

剑指E 发表于 2024-5-27 17:19
引用网友的话：
这是一体力活！

谢谢，环保、科学，那我就不下载了。

zpy2

没看明白对应关系，是不是需要一点 数据

ykcbf1100

就是体力活。

LIUZHU

弄个样例呗，有数据的，当然，数据太多，也会劝退很多人

longwin

请测试......

longwin

代码优化了一下，附件已更新。

Sub test()
Application.ScreenUpdating = False
Set d = CreateObject("Scripting.Dictionary")
Set d1 = CreateObject("Scripting.Dictionary")
Set sh = Sheets("Sheet1")
Set bg = Workbooks.Open(ThisWorkbook.Path & "\归户确认表.xlsx")
Set mbsh = bg.Sheets("Sheet1")

arr = sh.UsedRange
For i = 1 To sh.UsedRange.Columns.Count  '将栏目及对应的列号装入字典
    d("【" & sh.Cells(1, i).Value & "】") = i
Next

'按照户主将每户的开始行号及结束行号装入字典
For i = 2 To UBound(arr)
    If arr(i, 5) <> "" Then
        If i = 2 Then
            d1(arr(i, 5)) = Array(i, i)
            hz = arr(i, 5)
        Else
            d1(hz) = Array(d1(hz)(0), i - 1)
            d1(arr(i, 5)) = Array(i, i)
            hz = arr(i, 5)
        End If
    End If
Next

For Each Key In d1
    ksh = d1(Key)(0)   '开始行
    jsh = d1(Key)(1)    '结束行
    Set newbook = Workbooks.Add
    mbsh.Copy Before:=newbook.Sheets(1)
    Set bgsh = newbook.ActiveSheet
    newbookname = ThisWorkbook.Path & "\" & arr(ksh, 4) & ".xlsx"
    ssr = Split("4,4|4,13|4,21|5,7|45,4|68,15", "|")
    For j = 0 To UBound(ssr)
        h = CInt(Split(ssr(j), ",")(0))
        l = CInt(Split(ssr(j), ",")(1))
         bgsh.Cells(h, l) = arr(ksh, d(bgsh.Cells(h, l).Value))
    Next
    ssr = Split("10,25|28,36|52,67|70,85", "|")
    For j = 0 To UBound(ssr)
        k1 = CInt(Split(ssr(j), ",")(0))
        k2 = CInt(Split(ssr(j), ",")(1))
        For i = k1 To k2
                For Each cell In bgsh.Range(bgsh.Cells(i, 1), bgsh.Cells(i, 25))
                    If Left(cell.Value, 1) = "【" Then
                        If (i - k1) <= (jsh - ksh) Then
                            cell.Value = arr(ksh + (i - k1), d(cell.Value))
                        Else
                            cell.Value = ""
                        End If
                    End If
                Next
        Next
  Next
        newbook.SaveAs newbookname
        newbook.Close 0
Next
bg.Close
MsgBox "生成完毕！"
Application.ScreenUpdating = True
End Sub

wuqing960412

longwin 发表于 2024-5-27 21:33
代码优化了一下，附件已更新。

Sub test()

大神，为什么我修改内容就不能用了，麻烦能说一下嘛，谢谢

longwin