如何批量将两个表单数据填充到模板

漫不经心14

宿舍资产特别多，几百个宿舍复制粘贴到崩溃。
如何将固定资产和低值资产两个表单的数据填充到宿舍资产明细表相应的栏目中，请各位大佬们帮帮忙。要求如下：
1、相同地点的数据填充在同一个表，按一个地点生成一张明细表，14个宿舍就生成14张明细表。
2、明细表可以生成在同一个表单中，一路往下排，无需新建成独立文件或新表单。
3、明细表忆设置固定资产数量为9行，低值资产数量为15行，如果可以的话，明细表中的这两个行数能不能根据资产表的数据自动增减，在增减的基础上再进行限制，比如固定资产最少5行，低值资产最少10行（包括空白行）。


眼巴巴的在线等~~~~~

chengyunpan

你目的是打印还是生成，生成几百个明细往下排，也不好管理呢。用我的万能批量打印软件可以实现批量打印。软件在我的主页里面有，可以自行下载，不懂的再联系我

chengyunpan

在我论坛里面有，自己去下载

gwjkkkkk

Option Explicit
Sub TEST()
    Dim ar(3 To 4), br, i&, j&, k&, r&, dic As Object, vKey
    Dim Rng As Range, wks As Worksheet, t#, iPosRow&, iRowCount&


    DoApp False
    Set dic = CreateObject("Scripting.Dictionary")
    Set wks = Sheets("模板")
    t = Timer

    For i = 3 To 4
        ar(i) = Sheets(i).[A1].CurrentRegion
    Next i
    For i = 2 To UBound(ar(3)): dic(ar(3)(i, 7)) = "": Next

    With Workbooks.Add
         For Each vKey In dic.keys
             wks.Copy after:=.Sheets(.Sheets.Count)
             With .ActiveSheet
                 .Name = vKey
                 For i = 4 To 3 Step -1
                     ReDim cr(1 To UBound(ar(i)), 1 To UBound(ar(i), 2) + 1)
                     r = 0
                     For j = 2 To UBound(ar(i))
                         If ar(i)(j, 7) = vKey Then
                              r = r + 1
                              For k = 1 To UBound(ar(i), 2)
                                  cr(r, k + 1) = ar(i)(j, k)
                              Next k
                              cr(r, 1) = r
                         End If
                     Next j
                     iPosRow = IIf(i = 4, 11, 4)
                     iRowCount = IIf(i = 4, 10, 5)
                     If r > iRowCount Then
                         For j = 1 To r - iRowCount
                             .Rows(iPosRow + 1).Insert Shift:=xlDown
                         Next j
                     End If
                     .Cells(iPosRow, 1).Resize(r, UBound(cr, 2)) = cr
                 Next i
             End With
         Next vKey
         For Each wks In .Sheets
             If wks.Name Like "*Sheet*" Then wks.Delete
         Next
    End With

    Set dic = Nothing: Set wks = Nothing
    DoApp
    MsgBox "执行完毕!_用时:  " & Format(Timer - t, "0.00") & "  秒", 64
End Sub
Function DoApp(Optional b As Boolean = True)
    With Application
        .ScreenUpdating = b
        .DisplayAlerts = b
        .Calculation = -b * 30 - 4135
    End With
End Function

gwjkkkkk

请楼主参考附件，相关表格请勿删除。。。

chengyunpan

万能批量打印软件用于楼主的案例

chengyunpan

chengyunpan 发表于 2023-2-16 22:56
万能批量打印软件用于楼主的案例

忘了修改设置，按这个图片修改即行。

chengyunpan

忘了修改设置，按这个图片所示修改即行。

漫不经心14

gwjkkkkk 发表于 2023-2-16 21:07
请楼主参考附件，相关表格请勿删除。。。

感谢国民好网友，太太太感谢，完美解决问题。

漫不经心14

chengyunpan 发表于 2023-2-16 22:56
万能批量打印软件用于楼主的案例

太感谢了，这个也非常赞，可以一键打印。