Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 2029|回复: 5

[已解决]请教各位大神,把文件中的每条数据拆分成一个独立的文件,新文件的格式也要改变。

[复制链接]
发表于 2017-7-6 17:30 | 显示全部楼层 |阅读模式
请教各位大神,把一个文件中的每一条数据拆分成一个独立的文件,新文件的格式也要变。
要求:
新生成的每个文件对原表中的数据进行了简单的计算,这个怎么实现呢?上传个附件给大神们参考一下。
原表是:学生总表.xls,
新生成的表:以学生名字命名的文件:胡.xls,茅.xls......

最佳答案
2017-7-6 20:18
本帖最后由 苏子龙 于 2017-7-6 20:35 编辑
  1. Sub tt()
  2. Dim arr, i%, y%, n%, cl%
  3. Application.DisplayAlerts = False
  4. Application.ScreenUpdating = False
  5. Worksheets("模版").Select
  6. arr = Worksheets("Sheet1").Range("A1").CurrentRegion
  7. For i = 2 To UBound(arr)
  8.     Range("a2") = arr(i, 1)
  9.     Range("b2") = arr(i, 2)
  10.     Range("d2") = arr(i, 3)
  11.     Range("e2") = arr(i, 4)
  12.     Range("f2") = arr(i, 5)
  13.     Range("h2") = arr(i, 6)
  14.     Range("j2") = arr(i, 7)
  15.     Range("k2") = arr(i, 8)
  16.     Range("m2") = arr(i, 9)
  17.     Range("n2") = arr(i, 46)
  18.     For y = 10 To 29
  19.         cl = y Mod 2: n = Int(y / 2)
  20.         Cells(n, cl + 5) = arr(i, y)
  21.     Next
  22.         Range("e15") = arr(i, 31)
  23.         Range("f15") = arr(i, 32)
  24.         Range("e16") = arr(i, 34)
  25.         Range("f16") = arr(i, 35)
  26.         Range("e17") = arr(i, 36)
  27.         Range("f17") = arr(i, 37)
  28.         
  29.         Range("k5") = arr(i, 33)
  30.         Range("k6") = arr(i, 38)
  31.         Range("k7") = arr(i, 30)
  32.     For y = 39 To 45
  33.         Range("k" & y - 31) = arr(i, y)
  34.     Next

  35. Worksheets("模版").Copy
  36. ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "" & arr(i, 1) & ".xlsx"
  37. ActiveWorkbook.Sheets(1).Name = arr(i, 1)
  38. ActiveWorkbook.Close True
  39.   Next
  40. Application.DisplayAlerts = True
  41. Application.ScreenUpdating = True
  42. MsgBox "已完成拆分" & Chr(10) & "共:" & UBound(arr) - 1
  43. Worksheets("Sheet1").Select
  44. End Sub
复制代码

总表

总表

新表

新表

学生.zip

28.56 KB, 下载次数: 7

excel精英培训的微信平台,每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
 楼主| 发表于 2017-7-6 17:31 | 显示全部楼层
这个要写VBA代码吗?写了一个只能拆分表格。。。。好急
回复

使用道具 举报

发表于 2017-7-6 20:18 | 显示全部楼层    本楼为最佳答案   
本帖最后由 苏子龙 于 2017-7-6 20:35 编辑
  1. Sub tt()
  2. Dim arr, i%, y%, n%, cl%
  3. Application.DisplayAlerts = False
  4. Application.ScreenUpdating = False
  5. Worksheets("模版").Select
  6. arr = Worksheets("Sheet1").Range("A1").CurrentRegion
  7. For i = 2 To UBound(arr)
  8.     Range("a2") = arr(i, 1)
  9.     Range("b2") = arr(i, 2)
  10.     Range("d2") = arr(i, 3)
  11.     Range("e2") = arr(i, 4)
  12.     Range("f2") = arr(i, 5)
  13.     Range("h2") = arr(i, 6)
  14.     Range("j2") = arr(i, 7)
  15.     Range("k2") = arr(i, 8)
  16.     Range("m2") = arr(i, 9)
  17.     Range("n2") = arr(i, 46)
  18.     For y = 10 To 29
  19.         cl = y Mod 2: n = Int(y / 2)
  20.         Cells(n, cl + 5) = arr(i, y)
  21.     Next
  22.         Range("e15") = arr(i, 31)
  23.         Range("f15") = arr(i, 32)
  24.         Range("e16") = arr(i, 34)
  25.         Range("f16") = arr(i, 35)
  26.         Range("e17") = arr(i, 36)
  27.         Range("f17") = arr(i, 37)
  28.         
  29.         Range("k5") = arr(i, 33)
  30.         Range("k6") = arr(i, 38)
  31.         Range("k7") = arr(i, 30)
  32.     For y = 39 To 45
  33.         Range("k" & y - 31) = arr(i, y)
  34.     Next

  35. Worksheets("模版").Copy
  36. ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "" & arr(i, 1) & ".xlsx"
  37. ActiveWorkbook.Sheets(1).Name = arr(i, 1)
  38. ActiveWorkbook.Close True
  39.   Next
  40. Application.DisplayAlerts = True
  41. Application.ScreenUpdating = True
  42. MsgBox "已完成拆分" & Chr(10) & "共:" & UBound(arr) - 1
  43. Worksheets("Sheet1").Select
  44. End Sub
复制代码

学生.rar

44.02 KB, 下载次数: 7

回复

使用道具 举报

 楼主| 发表于 2017-7-7 12:16 | 显示全部楼层

真的太感谢了,我来试试看
回复

使用道具 举报

 楼主| 发表于 2017-7-7 12:23 | 显示全部楼层

老师,我在运行的时候,是不是要在原表格里面,新建一个模板的sheet啊,不然不会成功是吧?
回复

使用道具 举报

发表于 2017-7-7 18:39 | 显示全部楼层
在同一个工作簿里数据放在sheet1,模版取名模版,运行程序就好了,也可以我上传的工作簿里面,把数据复制到sheet1里面,运行就好了,自己检查是否有不对的地方,自己对应改改吧

评分

参与人数 1 +1 收起 理由
partylin + 1 赞一个

查看全部评分

回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-3-29 06:42 , Processed in 0.372283 second(s), 12 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表