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

z9bhd

xl6403 发表于 2021-3-26 09:43
谢谢你的回帖。下载测试了，可以运行成功。只是感觉要导入到模板工作表要在模板2工作表里把对应列号.xlsx ...

原来的那个代码是通用的，要一个一个点选单元格，不熟悉对应关系的很容易点错，我也试了很久，不知问题出在哪了，如果你要用原来那个代码，最好咨询写代码的那个高手，只有他最清楚问题的根源，我已尽力了，不好意思哦，我也再查查看有没有好一点的方法

z9bhd

xl6403 发表于 2021-3-26 09:43
谢谢你的回帖。下载测试了，可以运行成功。只是感觉要导入到模板工作表要在模板2工作表里把对应列号.xlsx ...

刚才又仔细看了一下，你的模板是excel文件，我的思路错了，按模板是word文档的思路去处理了，我晚上抽时间再改改看，应该可以省去填写列号这一步

z9bhd

xl6403 发表于 2021-3-26 09:43
谢谢你的回帖。下载测试了，可以运行成功。只是感觉要导入到模板工作表要在模板2工作表里把对应列号.xlsx ...

修改了一下，不用修改模板了，一键ok,我这里测试没发现问题，你再看看

z9bhd

修改.zip (47.69 KB, 下载次数: 111)

2021-3-26 16:43 上传

点击文件名下载附件

z9bhd

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 & "\模板1.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 = .Range("a4:aa27")
            For i = 1 To UBound(cr)
                For j = 1 To UBound(cr, 2)
                    If Right(cr(i, j), 1) = "列" Then
                        .Cells(i + 3, j) = d(ar(m, 1) & "-" & cr(i, j))
                    Else
                    Select Case cr(i, j)
                        Case "第一学期"
                            For s = 1 To 6
                            .Cells(i + s + 2, j + 1) = ar(m, 2 * (s - 1) + 16)
                            .Cells(i + s + 2, j + 6) = ar(m, 2 * (s - 1) + 17)
                            Next s
                        Case "第三学期"
                             For s = 1 To 4
                            .Cells(i + s + 2, j + 1) = ar(m, 2 * (s - 1) + 38)
                            .Cells(i + s + 2, j + 4) = ar(m, 2 * (s - 1) + 39)
                            Next s
                        Case "第五学期"
                             For s = 1 To 3
                            .Cells(i + s + 2, j + 1) = ar(m, 2 * (s - 1) + 52)
                            .Cells(i + s + 2, j + 4) = ar(m, 2 * (s - 1) + 53)
                            Next s
                        Case "第二学期"
                             For s = 1 To 3
                            .Cells(i + s + 2, j + 1) = ar(m, 2 * (s - 1) + 28)
                            .Cells(i + s + 2, j + 6) = ar(m, 2 * (s - 1) + 29)
                            Next s
                        Case "第四学期"
                             For s = 1 To 3
                            .Cells(i + s + 2, j + 1) = ar(m, 2 * (s - 1) + 44)
                            .Cells(i + s + 2, j + 4) = ar(m, 2 * (s - 1) + 45)
                            Next s
                        Case "第六学期"
                            For s = 1 To 3
                            .Cells(i + s + 2, j + 1) = ar(m, 2 * (s - 1) + 58)
                            .Cells(i + s + 2, j + 4) = ar(m, 2 * (s - 1) + 59)
                            Next s
                    End Select
                    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

紫寒100

z9bhd 发表于 2021-3-26 16:45
Sub 批量导出到模板3()
Dim ar, br, cr, i%, j%, wb1 As Workbook, wb2 As Workbook, wb As Workbook, d A ...

我有一个拆分其中一张表数据，拆分成工作簿，能否帮忙看一下。谢谢了。

紫寒100

z9bhd：你好，麻烦帮我看看呢，我是小白，实在是不懂。就是指定拆分一个工作簿里的某一张表另存为独立的工作簿。谢谢你啦。

z9bhd

紫寒100 发表于 2021-3-27 10:50
好像没传上来呢？怎么没有？就是指定拆分工作簿的某一张表别存为独立的工作簿。谢谢啦。

附件已下载，下午帮你看看，不一定能搞定

z9bhd

紫寒100 发表于 2021-3-27 11:00

附件下载看了一下，没搞懂你的意思，建议单发一贴让高手帮你看看