ExcelHome技术论坛

 找回密码
 免费注册
QQ登录 只需一步,快速开始
   
高效办公必会的Office99uu优优 永久免费,网表让Excel秒变数据库 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
Excel不给力? 何不试试FoxTable! Excel函数公式学习大典 资深财务总监教您玩转Excel 免费下载Excel行业应用视频
300集Office 2010微99uu优优 Tableau-数据可视化工具 突破Excel限制,用活字格提高效率 13门Excel免费公开课任你学
你的Excel 201099uu优优学习锦囊 欲罢不能, 过目难忘的 Office 新界面 免费的Excel考勤计算系统
查看: 137|回复: 7
打印 上一主题 下一主题

[求助] 求助 用VBA将一表,自动分解成N个独立excel文件

[复制链接]
TA的精华主题TA的得分主题
跳转到指定楼层
1
发表于 2018-1-13 15:17 | 只看该作者 回帖奖励 |倒序浏览 |阅读模式
求助 用VBA将一表,自动分解成N个独立excel文件这主表的数据在不断增加,如何VB 自动批处  根据“字段值”  分解成N个独立excel文件 文件名以 “字段值” 为名

字段值如“W10“

统计20180111.rar (195.55 KB, 下载次数: 4)


TA的精华主题TA的得分主题
2
发表于 2018-1-13 17:45 | 只看该作者
TA的精华主题TA的得分主题
3
发表于 2018-1-13 20:40 | 只看该作者
TA的精华主题TA的得分主题
4
发表于 2018-1-13 21:06 | 只看该作者
老师不动手就我来练习一下



统计20180111 abc123281.rar (689.96 KB, 下载次数: 2)

评分

参与人数 1财富 +20 收起 理由
lsc900707 + 20 值得肯定
查看全部评分
TA的精华主题TA的得分主题
5
发表于 2018-1-13 21:16 | 只看该作者
  • Sub gj23w98()
  •      c = Application.InputBox("请输入拆分列号", , 4, , , , , 1)
  •      If c = 0 Then Exit Sub
  •      Application.ScreenUpdating = False
  •      Application.DisplayAlerts = False
  •      arr = [a1].CurrentRegion
  •      m = UBound(arr): n = UBound(arr, 2)
  •      Set rng = [a1].Resize(, n)
  •      Set d = CreateObject("scripting.dictionary")
  •      For i = 2 To m
  •          If Not d.Exists(arr(i, c)) Then
  •              Set d(arr(i, c)) = Cells(i, 1).Resize(1, n)
  •          Else
  •              Set d(arr(i, c)) = Union(d(arr(i, c)), Cells(i, 1).Resize(1, n))
  •          End If
  •      Next
  •      k = d.Keys
  •      t = d.Items
  •      For i = 0 To d.Count - 1
  •          With Workbooks.Add(xlWBATWorksheet)
  •              rng.Copy .Sheets(1).[a1]
  •              t(i).Copy .Sheets(1).[a2]
  •              .SaveAs Filename:=ThisWorkbook.Path & "" & k(i)
  •              .Close
  •          End With
  •      Next
  •      Application.DisplayAlerts = True
  •      Application.ScreenUpdating = True
  •      MsgBox "完毕"
  • End Sub
  • 复制代码
    TA的精华主题TA的得分主题
    6
     楼主| 发表于 2018-1-14 23:32 | 只看该作者

    这代码有bug
    1. "c = Application.InputBox("请输入拆分列号", , 4, , , , , 1)" 如果选3或4 会炸出N+1 文件
    2.分解出来的文件不能定向存指定  文件夹

    TA的精华主题TA的得分主题
    7
    发表于 2018-1-15 00:06 | 只看该作者
  • 用于按照列的数据拆分单元格
  • Option Explicit
  • Sub bworksheet()
  • MsgBox "请在拆表之前对数据排序"
  • Dim arr()
  • Dim sh, ash As Worksheet: Set ash = ActiveSheet
  • Dim m, n, i, j, s, k As Long: j = 1
  • n = ash.Range("a60000").End(xlUp).Row
  • m = Val(InputBox("请输入您需要拆表判断的依据号"))
  • s = ash.UsedRange.Columns.Count
  • For i = 1 To n
  • If Cells(i, m) <> Cells(i + 1, m) Then
  • ReDim Preserve arr(j)
  • arr(j) = i + 1
  • j = j + 1
  • End If
  • Next
  • For k = 1 To UBound(arr) - 1
  • Set sh = Worksheets.Add
  • ash.Range(Cells(arr(k), 1), Cells(arr(k + 1) - 1, s)).Copy sh.Range("a2")
  • ash.Range(Cells(1, 1), Cells(1, s)).Copy sh.Range("a1")
  • sh.Name = sh.Cells(2, m)
  • Next
  • ash.Visible = False
  • End Sub
  • 复制代码




    之前写过一个拆成多个工作表的有点契合,你把后面改改凑合用吧。懒得再写了。
    TA的精华主题TA的得分主题
    8
    发表于 2018-1-15 00:08 | 只看该作者
  • 用于按照列的数据拆分单元格
  • Option Explicit
  • Sub bworksheet()
  • MsgBox "请在拆表之前对数据排序"
  • Dim arr()
  • Dim sh, ash As Worksheet: Set ash = ActiveSheet
  • Dim m, n, i, j, s, k As Long: j = 1
  • n = ash.Range("a60000").End(xlUp).Row
  • m = Val(InputBox("请输入您需要拆表判断的依据号"))
  • s = ash.UsedRange.Columns.Count
  • For i = 1 To n
  • If Cells(i, m) <> Cells(i + 1, m) Then
  • ReDim Preserve arr(j)
  • arr(j) = i + 1
  • j = j + 1
  • End If
  • Next
  • For k = 1 To UBound(arr) - 1
  • Set sh = Worksheets.Add
  • ash.Range(Cells(arr(k), 1), Cells(arr(k + 1) - 1, s)).Copy sh.Range("a2")
  • ash.Range(Cells(1, 1), Cells(1, s)).Copy sh.Range("a1")
  • sh.Name = sh.Cells(2, m)
  • Next
  • ash.Visible = False
  • End Sub

  • 复制代码


    之前写过一个拆成不同sheet 的 不想再写了你改改用吧 不行你再运行下下面这段代码拆成工作簿就好了

  • Sub 拆分工作簿()
  • Dim sh, bh As Worksheet
  • Dim b As Workbook
  • Application.DisplayAlerts = False
  • For Each sh In Sheets
  • Set b = Workbooks.Add
  • sh.Copy after:=b.Sheets(1)
  • For Each bh In b.Sheets
  • If bh.Name <> sh.Name Then
  • bh.Delete
  • End If
  • Next
  • b.SaveAs Filename:=ThisWorkbook.Path & "/" & sh.Name & ".xlsx"
  • b.Close
  • Next
  • Application.DisplayAlerts = True
  • End Sub
  • 复制代码
    您需要登录后才可以回帖 登录 | 免费注册
    本版积分规则
    关闭

    最新热点上一条 /1 下一条

    关注官方微信,每天学会一个新技能
    手机版|关于我们|联系我们|ExcelHome GMT+8, 2018-4-25 06:46 , Processed in 0.071663 second(s), 18 queries , Gzip On, MemCache On.
    Powered by Discuz! X3.4 © 2001-2017 Wooffice Inc.
        沪公网安备 31011702000001号 沪ICP备11019229号 本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:徐怀玉律师 李志群律师
    快速回复 返回顶部 返回列表
    99uu优优