将excel的数据导入已有的模板中

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