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

xl6403

cjc209 发表于 2021-1-22 17:33
结果在结果文件夹里 对应关系 你自己才知道怎么去匹配

我经过多次测试，操作步骤没有错，可以看录屏视频，但是就是运行不能到底。不知为什么？总是在保存时出错。我的电脑是64位WIN10，OFFICE2019

xl6403

到现在也没有一次测试成功。

xl6403

xl6403 发表于 2021-1-28 16:03
老师，很不好意思。通过多次测试，发现仍然与原来一样。具体操作见附件的操作录屏视频，为什么会这样？我 ...

有哪位也下载测试了的？能运行下去么？

xl6403

这么久了还没有解决问题。

xl6403

刚才打开帖子看错了楼层，以为有了新回复，有一点欣喜若狂，便马上回复，等我查看一下前面的回复后才发现是看错了，

xl6403

cjc209 发表于 2021-1-22 09:33
Sub 批量导出到模板()
Dim myPath, myName
Dim arr As Variant

你好，我今天又一次测试了你的程序（26楼和你帮我修改了一下的程序），26楼的程序有选择保存位置的提示，帮我修改了没有选择。但是结果都是到要保存时运行停止。是什么原因呢？麻烦你再研究研究。

xl6403

每次测试程序，都是到最后保存时出错，跳出提示对话框：
                      运行时错误‘1004’:方法 ‘SaveAs’作用于对象‘_Workbook’时失败
点调试，停在这一句：
                       wb.SaveAs Filename:=Directory & "\" & bm & ".xls"

这是测试26楼的程序，程序复制如下：

1. Sub 批量导出到模板()
   
2. Dim myPath, myName
   
3. Dim arr As Variant
   
4. Dim i, s As Integer, arr2(), arr1(), arr3()
   
5. Dim wb As Workbook
   
6. Set Mapp = CreateObject("Shell.Application").BrowseForFolder(0, "请选择保存结果文件的存放目录：", &H1)
   
7.     If Not Mapp Is Nothing Then
   
8.         Directory = Mapp.self.Path
   
9.     Else
   
10.         MsgBox "你没有选择保存目录！": Exit Sub
    
11.     End If
    
12. Set zsj = Application.InputBox("请点选： 数据源中的任意非空单元格", Type:=8)
    
13. Set zdm = Application.InputBox("请在该表中点选 或者框选匹配需要的： 字段名", Type:=8)
    
14. zdmhh = Val(Application.InputBox("请输入总数据源中 _字段 所处的最末行号信息 为数字型 1  2  3 4....", "默认值", "1"))
    
15. arr = zsj.CurrentRegion.Offset(zdmhh - 1, 0)
    
16. Set gzbm = Application.InputBox("请点选：以什么字段名来命名新工作簿", Type:=8)
    
17. bml = gzbm.Column
    
18. For Each zdm1 In zdm
    
19. nn = nn + 1
    
20. ReDim Preserve arr1(1 To nn)
    
21. arr1(nn) = zdm1.Value
    
22. Next
    
23.     myPath = ThisWorkbook.Path & "\*.xls*"
    
24.     myName = Dir(myPath)
    
25.     Do While myName <> ""
    
26.        If myName <> ThisWorkbook.Name Then mbbm = myName
    
27.         myName = Dir()
    
28.     Loop
    
29. Set wb = Workbooks.Open(ThisWorkbook.Path & "" & mbbm)
    
30. For Each Rng In arr1
    
31.   tt = "原始数据中的  " & Rng & "  列匹配到模板中的对应位置："
    
32.    n = n + 1
    
33.    If Rng = gzbm Then
    
34.     bmxh = n
    
35.    End If
    
36. Set tishi = Application.InputBox(tt, Type:=8)
    
37. Set sh = tishi.Parent
    
38.   sh.Activate
    
39.   scbm = tishi.Parent.Name
    
40. ReDim Preserve arr2(1 To n)
    
41. ReDim Preserve arr3(1 To n)
    
42. arr2(n) = tishi.Address(0, 0)
    
43. arr3(n) = scbm
    
44. Next Rng
    
45.    Application.ScreenUpdating = False
    
46.    Application.DisplayAlerts = False
    
47. For i = 2 To UBound(arr)
    
48.   For j = 1 To UBound(arr2)
    
49.     For k = 1 To UBound(arr, 2)
    
50.      If arr1(j) = arr(1, k) Then
    
51.       wb.Sheets(arr3(j)).Range(arr2(j)) = arr(i, k)
    
52.      End If
    
53.      Next
    
54.    Next
    
55.   bm = arr(i, bml)
    
56.   wb.SaveAs Filename:=Directory & "" & bm & ".xls"
    
57. Next i
    
58. wb.Close False
    
59.   Application.DisplayAlerts = True
    
60.   Application.ScreenUpdating = True
    
61.   MsgBox "导出完毕！"
    
62. End Sub

复制代码

z9bhd

不知能不能用
Sub lx()
    Dim ar, br, i%, j%, d As Object, wb1 As Workbook, wb As Workbook
        Set wb1 = ThisWorkbook
        ar = wb1.Sheets(1).UsedRange
        Set d = CreateObject("scripting.dictionary")
        For i = 2 To UBound(ar)
            For j = 2 To UBound(ar, 2)
                If j <= 4 Then
                    d(ar(i, 1) & "-" & ar(1, j)) = ar(i, j)
                Else
                    d(ar(i, 1) & "-" & Left(ar(1, j), 3)) = ar(i, j)
                End If
            Next j
        Next i
        Set wb = Workbooks.Open(wb1.Path & "\模板表.xls")
        For m = 1 To UBound(ar) - 1
            br = wb.Sheets(1).Range("a6:d17")
            For i = 1 To UBound(br)
                For j = 1 To UBound(br, 2)
                    Select Case Trim(br(i, j))
                        Case "员工姓名"
                            br(i + 1, j) = ar(m + 1, 1)
                        Case "入职日期"
                            br(i + 1, j) = d(ar(m + 1, 1) & "-" & Trim(br(i, j)))
                        Case "所属部门"
                            br(i + 1, j) = d(ar(m + 1, 1) & "-" & Trim(br(i, j)))
                        Case "职位"
                            br(i + 1, j) = d(ar(m + 1, 1) & "-" & Trim(br(i, j)))
                        Case "调整前"
                            br(i + 4, j) = d(ar(m + 1, 1) & "-" & Trim(br(i, j)))
                        Case "调整后"
                            br(i + 4, j) = d(ar(m + 1, 1) & "-" & Trim(br(i, j)))
                        End Select
                Next j
            Next i
            Set wb2 = Workbooks.Add
                wb.Sheets(1).Copy wb2.Sheets(1)
                wb2.Sheets(1).[a6].Resize(UBound(br), UBound(br, 2)) = br
                wb2.SaveAs (wb1.Path & "\薪酬变动申请表" & "-" & ar(m + 1, 1) & ".xlsx")
                wb2.Close
        Next m
End Sub

z9bhd

人员汇总表.zip (14.1 KB, 下载次数: 65)

2021-3-21 13:15 上传

点击文件名下载附件

xl6403

z9bhd 发表于 2021-3-21 13:15

谢谢你的回帖。
这个程序作用的工作表不是你发的那种样式，程序在这个帖子里有，我都要放到附件里，麻烦你看看，批量导出到模板2是批量导出到模板1修改版，区别在于批量导出到模板2取消了选择保存文件夹。
从数据到模板.rar (32.4 KB, 下载次数: 57)

2021-3-22 08:53 上传

点击文件名下载附件