|
发表于 2017-7-6 20:18
|
显示全部楼层
本楼为最佳答案
本帖最后由 苏子龙 于 2017-7-6 20:35 编辑
- Sub tt()
- Dim arr, i%, y%, n%, cl%
- Application.DisplayAlerts = False
- Application.ScreenUpdating = False
- Worksheets("模版").Select
- arr = Worksheets("Sheet1").Range("A1").CurrentRegion
- For i = 2 To UBound(arr)
- Range("a2") = arr(i, 1)
- Range("b2") = arr(i, 2)
- Range("d2") = arr(i, 3)
- Range("e2") = arr(i, 4)
- Range("f2") = arr(i, 5)
- Range("h2") = arr(i, 6)
- Range("j2") = arr(i, 7)
- Range("k2") = arr(i, 8)
- Range("m2") = arr(i, 9)
- Range("n2") = arr(i, 46)
- For y = 10 To 29
- cl = y Mod 2: n = Int(y / 2)
- Cells(n, cl + 5) = arr(i, y)
- Next
- Range("e15") = arr(i, 31)
- Range("f15") = arr(i, 32)
- Range("e16") = arr(i, 34)
- Range("f16") = arr(i, 35)
- Range("e17") = arr(i, 36)
- Range("f17") = arr(i, 37)
-
- Range("k5") = arr(i, 33)
- Range("k6") = arr(i, 38)
- Range("k7") = arr(i, 30)
- For y = 39 To 45
- Range("k" & y - 31) = arr(i, y)
- Next
- Worksheets("模版").Copy
- ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "" & arr(i, 1) & ".xlsx"
- ActiveWorkbook.Sheets(1).Name = arr(i, 1)
- ActiveWorkbook.Close True
- Next
- Application.DisplayAlerts = True
- Application.ScreenUpdating = True
- MsgBox "已完成拆分" & Chr(10) & "共:" & UBound(arr) - 1
- Worksheets("Sheet1").Select
- End Sub
复制代码 |
|