ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 9119|回复: 46

[分享] 灵活拆分工具

  [复制链接]

TA的精华主题

TA的得分主题

发表于 2020-2-12 14:44 | 显示全部楼层 |阅读模式
本帖最后由 3190496160 于 2020-3-8 17:07 编辑

基本思路:借助vba中的inputbox函数,自由选择标题区域,自由选择拆分后需要保留的列区域,自由选择拆分关键字所在列,从而实现了拆分的灵活和通用,
Sub 灵活拆分()
Dim d As Object
Dim rng1 As Range
Dim rng2 As Range
Dim rng3 As Range
Set d = CreateObject("scripting.dictionary")
Application.DisplayAlerts = False
For Each sh In Sheets
    If sh.Name <> ActiveSheet.Name Then sh.Delete
Next sh
Application.DisplayAlerts = True
Set sh = ActiveSheet
On Error Resume Next
Set rng1 = Application.InputBox("请选择拆分后要保存的列区域区域", "选取提示", , , , , , 8)
If rng1 Is Nothing Then MsgBox "您没有选择要保存的列区域": Exit Sub

Set rng2 = Application.InputBox("请选择标题区域", "选取提示", , , , , , 8)
If rng2 Is Nothing Then MsgBox "您没有选择标题区域": Exit Sub
p1 = rng2.Rows.Count + rng2.Row - 1

Set rng3 = Application.InputBox("请选择拆分列", "选取提示", , , , , , 8)
If rng3 Is Nothing Then MsgBox "您没有选择拆分列": Exit Sub
p2 = rng3.Column
Application.ScreenUpdating = False
ks = rng1.Column
js = rng1.Columns.Count + rng1.Column - 1
With ActiveSheet
    Set bt = .Range(.Cells(1, ks), .Cells(Val(p1), js))
    x = .Cells(Rows.Count, p2).End(xlUp).Row
    y = .Cells(p1, Columns.Count).End(xlToLeft).Column
    ar = .Range(.Cells(1, 1), .Cells(x, y))
End With
For i = p1 + 1 To UBound(ar)
    If Trim(ar(i, Val(p2))) <> "" Then
        d(Trim(ar(i, Val(p2)))) = ""
    End If
Next i
For Each k In d.keys
    n = 0
    ReDim br(1 To UBound(ar), 1 To (js - ks + 1))
    For i = p1 + 1 To UBound(ar)
        If Trim(ar(i, Val(p2))) = k Then
            n = n + 1
            y = 0
            For j = ks To js
                y = y + 1
                br(n, y) = ar(i, j)
            Next j
        End If
    Next i
    Set sht = Worksheets.Add(after:=Sheets(Sheets.Count))
    sht.Name = k
    bt.Copy sht.[a1]
    sht.Cells(p1 + 1, 1).Resize(n, UBound(br, 2)) = br
    sht.Cells(p1 + 1, 1).Resize(n, UBound(br, 2)).Borders.LineStyle = 1
    t = 0
    For j = ks To js
        t = t + 1
        sht.Columns(t).ColumnWidth = sh.Columns(j).ColumnWidth
    Next j
Next k
Application.ScreenUpdating = True
MsgBox "共生成了" & d.Count & "个工作表"
End Sub


评分

2

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-8-31 10:39 | 显示全部楼层
在功能上做了很多改进,
1。把操作放到了窗体中来完成,
2.可以自由选择需要保留的不连续的列
3.可以自由选择需要拆分的文件
【拆分工具】灵活拆分之一(自由选择拆分后需保留的列).rar (1.71 MB, 下载次数: 641)

评分

2

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2021-9-6 15:11 | 显示全部楼层
增加了拆分时的条件判断,消除了使用过程中发现的bug,需要者请务必在该楼下载

【拆分工具】灵活拆分之一(自由选择拆分后需保留的列).rar (33.29 KB, 下载次数: 280)

评分

3

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-2-12 14:45 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
灵活拆分工具(20200212).rar (29.8 KB, 下载次数: 333)

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2020-2-28 13:55 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2020-3-5 17:06 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2020-3-5 17:18 | 显示全部楼层
将Application.ScreenUpdating = False放在几个选择框语句的后面就行了。

Set rng1 = Application.InputBox("请选择拆分后要保存的列区域区域", "选取提示", , , , , , 8)
If rng1 Is Nothing Then MsgBox "您没有选择要保存的列区域": Exit Sub

Set rng2 = Application.InputBox("请选择标题区域", "选取提示", , , , , , 8)
If rng2 Is Nothing Then MsgBox "您没有选择标题区域": Exit Sub
p1 = rng2.Rows.Count + rng2.Row - 1

Set rng3 = Application.InputBox("请选择拆分列", "选取提示", , , , , , 8)
If rng3 Is Nothing Then MsgBox "您没有选择拆分列": Exit Sub

Application.ScreenUpdating = False
p2 = rng3.Column
ks = rng1.Column
js = rng1.Columns.Count + rng1.Column - 1
……
……

评分

1

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-3-8 17:09 | 显示全部楼层
更新和修改了代码的附件,需要请在此下载
灵活拆分工具(20200212).rar (30.55 KB, 下载次数: 199)

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2020-3-8 19:02 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
本帖最后由 FOB_FN_L 于 2020-3-8 19:07 编辑
3190496160 发表于 2020-3-8 17:09
更新和修改了代码的附件,需要请在此下载

楼主白费心血分享了,下载量才68次,看你代码的人不多呀~~
看了一下,楼主需要点“装饰”的,加个窗体,选择条件在窗体上,别的网站10年前就有人写出来过,楼主可以看一下那个和你的这功能上基本一样,完全是自定义的参数选择,比如,拆分到当前工作薄或一个新的工作薄等等这些条件弄个小窗体,更完美了

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-3-8 19:21 | 显示全部楼层
FOB_FN_L 发表于 2020-3-8 19:02
楼主白费心血分享了,下载量才68次,看你代码的人不多呀~~
看了一下,楼主需要点“装饰”的, ...

用窗体来设置参数,手里面也有自己做的成熟的工具,但是有他的缺陷,就是必须依赖窗体,别人使用的时候非得吧数据拷贝进来才行,所才想到用这种方式的,其实,各有千秋了

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-3-8 19:22 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
增加了拆分为 工作簿的功能,
灵活拆分工具(20200212).rar (24.59 KB, 下载次数: 367)

评分

2

查看全部评分

TA的精华主题

TA的得分主题

发表于 2020-3-8 19:27 | 显示全部楼层
3190496160 发表于 2020-3-8 19:22
增加了拆分为 工作簿的功能,

很优秀了,在内容搜索方面涉猎过没,
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-3-29 00:28 , Processed in 0.073876 second(s), 21 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

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