Question

Excel 如何将数据导入模板生成新的EXCEL文件

Answer 1

代码：
Sub Macro1()
Dim arr, brr(), crr(1 To 30, 3 To 8), d As Object, k, t, a, i&, j&, m&, l& Dim w As WorksheetFunction, sh As Worksheet, wb As Workbook Application.ScreenUpdating = False Application.DisplayAlerts = False
Set d = CreateObject("scripting.dictionary") arr = [a1].CurrentRegion For i = 2 To UBound(arr)
s = arr(i, 2) & "_" & arr(i, 3) d(s) = d(s) & "," & i Next
k = d.Keys t = d.Items
Set sh = Sheets("模板") Set w = WorksheetFunction For i = 0 To d.Count - 1 a = Split(t(i), ",")
ReDim brr(1 To w.RoundUp(UBound(a) / 30, 0) * 30, 3 To 8) For j = 1 To UBound(a) brr(j, 3) = j For l = 4 To 8
brr(j, l) = arr(a(j), l) Next Next m = j - 1
For j = w.RoundUp(m / 30, 0) * 30 To 1 Step -30 f = j - 29
If wb Is Nothing Then sh.Copy
Set wb = ActiveWorkbook Else
sh.Copy Before:=wb.Sheets(1) End If
With ActiveSheet
.[A2] = .[A2] & Split(k(i), "_")(0) .[A3] = .[A3] & Split(k(i), "_")(1)
If m <= 30 Then
.[a5].Resize(m, 6) = brr .Name = k(i) Else
Erase crr n = 0
For v = f To f + 29 n = n + 1 For l = 3 To 8
crr(n, l) = brr(v, l) Next Next
.[a5].Resize(30, 6) = crr End If End With Next
If m > 30 Then
For j = 1 To wb.Sheets.Count wb.Sheets(j).Name = k(i) & j Next End If
wb.Close True, Filename:=ThisWorkbook.Path & "\" & k(i) & ".xls" Set wb = Nothing Next
Application.DisplayAlerts = True Application.ScreenUpdating = True MsgBox "ok" End Sub