【急！】如何从一个Excel表中提取数据，自动填入指定模板，生成多个Excel文件？

z9bhd

xl6403 发表于 2021-3-22 08:53
谢谢你的回帖。
这个程序作用的工作表不是你发的那种样式，程序在这个帖子里有，我都要放到附 ...

不好意思，我看错了，我是回一楼的，发错了哈，你的我下载看了一下，比我高明多了，我真的搞不定

xl6403

z9bhd 发表于 2021-3-22 10:11
不好意思，我看错了，我是回一楼的，发错了哈，你的我下载看了一下，比我高明多了，我真的搞不定

那也不是我编程的，是26楼回帖的高手。你下载了能不能测试通过？我测试到保存这一步就卡住了。

z9bhd

xl6403 发表于 2021-3-22 14:41
那也不是我编程的，是26楼回帖的高手。你下载了能不能测试通过？我测试到保存这一步就卡住了。

一样一样，到这一步bm的值为空

xl6403

z9bhd 发表于 2021-3-22 15:01
一样一样，到这一步bm的值为空

到哪下一步？你的回帖太简短了。麻烦你截图或复制代码。

z9bhd

xl6403 发表于 2021-3-22 15:30
到哪下一步？你的回帖太简短了。麻烦你截图或复制代码。

我是接你的话题说的，你说停在保存这一步，我也是在这步停止，你这时把鼠标指向停止的代码中的bm显示为空

xl6403

z9bhd 发表于 2021-3-22 15:45
我是接你的话题说的，你说停在保存这一步，我也是在这步停止，你这时把鼠标指向停止的代码中的bm显示为空

噢，谢谢指导。你能对此进行修改吗？

z9bhd

xl6403 发表于 2021-3-23 08:41
噢，谢谢指导。你能对此进行修改吗？

哪里敢说指导？说不定你比我掌握的更好，我学vba起因是为了处理中考数学试卷，excel vba学习也就几个月时间，现在还没入门呢。你说的问题我再看看，估计不会有什么结果

z9bhd

原代码是一个通用模板，要一个一个去点选单元格，比较麻烦，所以就重新写了个代码，前提是你要修改你的模板，我修改了一部分且把单元格对应关系文件也打包在压缩文件里，你再添加一些就可以了，我这里测试没问题，你试一下看
修改.zip (53.08 KB, 下载次数: 97)

2021-3-24 13:53 上传

点击文件名下载附件

z9bhd

xl6403 发表于 2021-3-23 08:41
噢，谢谢指导。你能对此进行修改吗？

Sub 批量导出到模板3()
Dim ar, br(), cr, i%, j%, wb1 As Workbook, wb2 As Workbook, wb As Workbook, d As Object
    Set wb1 = ThisWorkbook
    ar = wb1.Sheets("数据").Range("a2:bo" & Cells(Rows.Count, 1).End(xlUp).Row)
    ReDim br(1 To UBound(ar) + 1, 1 To UBound(ar, 2))
    Set d = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(ar)
        For j = 1 To UBound(ar, 2)
            br(1, j) = Replace(Cells(1, j).Address(False, False), "1", "") & "列"
            br(i + 1, j) = ar(i, j)
        Next j
    Next i
    Set wb2 = Workbooks.Open(wb1.Path & "\模板2.xls")
    For m = 1 To UBound(ar)
        For j = 2 To UBound(br, 2)
            d(br(m + 1, 1) & "-" & br(1, j)) = br(m + 1, j)
        Next j
        Set wb = Workbooks.Add
        wb2.Sheets.Copy before:=wb.Sheets(1)
        With wb.Sheets("工作表1")
            cr = .UsedRange
            For i = 4 To UBound(cr)
                For j = 1 To UBound(cr, 2)
                    If Right(cr(i, j), 1) = "列" Then
                        .Cells(i, j) = d(ar(m, 1) & "-" & cr(i, j))
                    End If
                Next j
            Next i
            .Cells(5, 10).Value = ar(m, 1)
        End With
        wb.SaveAs (wb1.Path & "\" & ar(m, 2) & ".xlsx")
        wb.Close
        d.RemoveAll
    Next m
    MsgBox "导出完毕！"
End Sub

xl6403

z9bhd 发表于 2021-3-24 13:53
原代码是一个通用模板，要一个一个去点选单元格，比较麻烦，所以就重新写了个代码，前提是你要修改你的模板 ...

谢谢你的回帖。下载测试了，可以运行成功。只是感觉要导入到模板工作表要在模板2工作表里把对应列号.xlsx文件里的列号一一填入到相应单元格里，还是比较麻烦。如能修改原能用程序，让它能够完成最后的保存更理好。