如何迅速的按模版输出文件 解除简单重复操作 谢谢

qc2t

如何以 报告数据.xlsx 中数据 按模版.xlsx 生成 CQ24_10.xlsx CQ24_11.xlsx CQ24_12.xlsx(报告数据.xlsx[C列数据做为要生成的文件名])   
谢谢

lizhipei78

不明白生成数据的逻辑

gwjkkkkk

Option Explicit
Sub TEST7()
    Dim ar, br, cr, i&, j&, dic As Object, strJoin$, vKey
    Dim wks As Worksheet, strPath$, strFileName$, n&, t#
   
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
    t = Timer
   
    With [A1].CurrentRegion
        ar = .Value
        For i = 2 To UBound(ar)
            If Not dic.exists(ar(i, 3)) Then
                dic(ar(i, 3)) = .Rows(i).Value
            End If
        Next i
    End With
   
    strPath = ThisWorkbook.Path & "\"
    br = Array("B3", "G10", "G14", "G15", "G16", "G17", "G18", "G21")
    cr = Array(Array(1), Array(2), Array(4, 13), Array(5, 14), Array(6, 15), Array(7, 16), Array(8, 9, 10, 11, 17, 18, 19, 20), Array(12, 21))
    With GetObject(strPath & "\模版.xlsx")
        Set wks = .Worksheets(1)
        For Each vKey In dic.keys
            ar = dic(vKey)
            wks.Copy
            With ActiveWorkbook
                strFileName = strPath & vKey
                With .Worksheets(1)
                    For i = 0 To UBound(br)
                        strJoin = ""
                        For j = 0 To UBound(cr(i))
                            strJoin = strJoin & "/" & ar(1, cr(i)(j))
                        Next j
                        .Range(br(i)).Value = Mid(strJoin, 2)
                    Next i
                End With
                .SaveAs strFileName
                .Close
            End With
        Next
        .Close False
    End With
   
    n = dic.Count
    Set dic = Nothing
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "执行完毕!_用时:  " & Format(Timer - t, "0.00") & "  秒" & vbCrLf & "共生成" & n & "个文件", 64
End Sub

gwjkkkkk

请参考附件。。。

qc2t

gwjkkkkk 发表于 2024-2-17 18:54
请参考附件。。。

谢谢，，向你学习。。。