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

q2369182

深夜mark 学习

xl6403

做个记号，有空学习一下。

xl6403

我是么么茶 发表于 2017-1-22 14:10
我试了一下，完全没问题，真的非常感谢您，谢谢，谢谢，收到陌不相识的你的热心帮忙，我都感动快哭了，谢 ...

我下载了版主的附件，把代码放在《人员汇总表》里，运行后出现如下提示：


点调试，停止在如下这句：


请问是什么原因？

xl6403

魂断蓝桥 发表于 2017-1-22 12:41
Sub a()
Dim sh As Worksheet
Application.DisplayAlerts = False

我下载了版主的附件，把代码放在《人员汇总表》里，运行后出现如下提示：


点调试，停止在如下这句：


请问是什么原因？

cjc209

给你一个分发模板的通用代码 这个代码放在总数据表的文件模块里 模板文件同时放在同一文件夹内 按操作提示 动动鼠标就行了

cjc209

Sub 批量导出到模板()
Dim myPath, myName
Dim arr As Variant
Dim i, s As Integer, arr2(), arr1(), arr3()
Dim wb As Workbook
Set Mapp = CreateObject("Shell.Application").BrowseForFolder(0, "请选择保存结果文件的存放目录：", &H1)
    If Not Mapp Is Nothing Then
        Directory = Mapp.self.Path
    Else
        MsgBox "你没有选择保存目录！": Exit Sub
    End If
Set zsj = Application.InputBox("请点选： 数据源中的任意非空单元格", Type:=8)
Set zdm = Application.InputBox("请在该表中点选 或者框选匹配需要的： 字段名", Type:=8)
zdmhh = Val(Application.InputBox("请输入总数据源中 _字段 所处的最末行号信息 为数字型 1  2  3 4....", "默认值", "1"))
arr = zsj.CurrentRegion.Offset(zdmhh - 1, 0)
Set gzbm = Application.InputBox("请点选：以什么字段名来命名新工作簿", Type:=8)
bml = gzbm.Column
For Each zdm1 In zdm
nn = nn + 1
ReDim Preserve arr1(1 To nn)
arr1(nn) = zdm1.Value
Next
    myPath = ThisWorkbook.Path & "\*.xls*"
    myName = Dir(myPath)
    Do While myName <> ""
       If myName <> ThisWorkbook.Name Then mbbm = myName
        myName = Dir()
    Loop
Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & mbbm)
For Each Rng In arr1
  tt = "原始数据中的  " & Rng & "  列匹配到模板中的对应位置："
   n = n + 1
   If Rng = gzbm Then
    bmxh = n
   End If
Set tishi = Application.InputBox(tt, Type:=8)
Set sh = tishi.Parent
  sh.Activate
  scbm = tishi.Parent.Name
ReDim Preserve arr2(1 To n)
ReDim Preserve arr3(1 To n)
arr2(n) = tishi.Address(0, 0)
arr3(n) = scbm
Next Rng
   Application.ScreenUpdating = False
   Application.DisplayAlerts = False
For i = 2 To UBound(arr)
  For j = 1 To UBound(arr2)
    For k = 1 To UBound(arr, 2)
     If arr1(j) = arr(1, k) Then
      wb.Sheets(arr3(j)).Range(arr2(j)) = arr(i, k)
     End If
     Next
   Next
  bm = arr(i, bml)
  wb.SaveAs Filename:=Directory & "\" & bm & ".xls"
Next i
wb.Close False
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
  MsgBox "导出完毕！"
End Sub

cjc209

这类型的没有难度  主要就是找对应关系 代码基本结构是不变的 变化的就是对应位置关系

cjc209

代码在审查中         

xl6403

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

老师你好，我复制了代码试运行，点到最后一个数据的位置时就跳出如下图的提示：

语句停止在这句：



到此前功尽弃了。什么原因？

cjc209

xl6403 发表于 2021-1-22 15:46
老师你好，我复制了代码试运行，点到最后一个数据的位置时就跳出如下图的提示：

语句停止在这句：

你要选择保存的文件夹