ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

EH搜索     
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
Excel不给力? 何不试试FoxTable! Excel 2016函数公式学习大典 Office知识技巧免费学 打造核心竞争力的职场宝典
300集Office 2010微视频教程 Tableau-数据可视化工具 精品推荐-800套精选PPT模板,点击获取 ExcelHome出品 - VBA代码宝免费下载
你的Excel 2010实战技巧学习锦囊 欲罢不能, 过目难忘的 Office 新界面 Excel VBA经典代码实践指南
查看: 347|回复: 12

[求助] VBA通过归类信息实现自动分组

[复制链接]

TA的精华主题

TA的得分主题

发表于 2020-1-10 21:25 | 显示全部楼层 |阅读模式
请论坛VBA大大们帮忙实现下

如图所示,客户需求分为三级,SA,RR,AA;其中SA为最高级客户需求,RR为次级(包含SA信息),AA为末级(包含RR和SA信息);
当前希望通过VBA实现自动分组,将属于同一个RR下的AA进行组合,同属于一个SA下的RR(含AA)进行组合;
注意实现:
1)如果SA下无RR,直接为下一个SA,则该SA不分组;
2)同理RR

图片.png

vba test - shuzu.rar

13.33 KB, 下载次数: 12

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-1-10 21:46 | 显示全部楼层
自己尝试了多次,觉得关键是要如何表示出同类的首行和末尾行,然后通过ROWS(XX:XX).group来处理,但始终实现不了

TA的精华主题

TA的得分主题

发表于 2020-1-10 23:06 | 显示全部楼层
参见附件。

vba test - shuzu.rar

39.22 KB, 下载次数: 13

评分

参与人数 1鲜花 +2 收起 理由
白鹰之约 + 2 优秀作品

查看全部评分

TA的精华主题

TA的得分主题

发表于 2020-1-11 08:30 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2020-1-11 10:56 | 显示全部楼层
本帖最后由 yjh_27 于 2020-1-11 11:13 编辑

调用分组过程有多种方法,可选择:
按指定字符"."数量分组:'Call AddOutline(arr, 2, 1, ".", "2,2,2")
                             或  Call AddOutline(arr, 2, 1, ".", "2")
按长度分组:'Call AddOutline(arr, 2, 1, 1, "15,6")
按指定首字符分组:Call AddOutline(arr, 2, 1, 6, "SA,RR,*")
                        或  Call AddOutline(arr, 2, 1, 6, "SA,RR,AA")

评分

参与人数 1鲜花 +2 收起 理由
LSYYLW + 2 太强大了

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-1-11 20:30 | 显示全部楼层

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-1-11 20:34 | 显示全部楼层

版主太强大了,代码非常精简干练,版主能分享下思路么?
下面做了一些参数修改,可以将结果更加完善
Sub Zdzh_Click(control As IRibbonControl)
    Call 自动组合
End Sub
Sub 自动组合()
    Dim nRow%, Arr(), Brr(1 To 2)
    nRow = Range("b1048576").End(xlUp).Row
    Arr = Range("b1:b" & nRow).Value
    Application.ScreenUpdating = False
    Range("a1:a" & nRow).EntireRow.ClearOutline
    For i = 2 To nRow
        If Not Arr(i, 1) Like "AA.*" Then
            If Brr(2) > 0 And i - Brr(2) > 1 Then‘此处修改为Brr(2) > 0 And i - Brr(2) > 0
                Range("a" & Brr(2) & ":a" & i - 1).EntireRow.Group
            End If
            If Arr(i, 1) Like "SA.*" And Brr(1) > 0 And i - Brr(1) > 1 (修改为0)Then
                Range("a" & Brr(1) & ":a" & i - 1).EntireRow.Group
            End If
            If Arr(i, 1) Like "SA.*" Then Brr(1) = i + 1
            Brr(2) = i + IIf(Arr(i, 1) Like "RR.*", 1, 2)
        End If
    Next
    Application.ScreenUpdating = True
End Sub

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-1-11 20:36 | 显示全部楼层

里面还有个问题,SA的组合是通过检测下一个SA的行号来实现的,而最后一个SA并没有下一个SA,因此最后一个SA不会自动组合

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-1-11 20:37 | 显示全部楼层
白鹰之约 发表于 2020-1-11 20:34
版主太强大了,代码非常精简干练,版主能分享下思路么?
下面做了一些参数修改,可以将结果更加完善
Su ...

代码基本看懂了,但是写代码之前的思路是怎么梳理的呢,我一直卡在如何表达同类的最后一行和起始行怎么实现

TA的精华主题

TA的得分主题

发表于 2020-1-11 20:49 | 显示全部楼层
白鹰之约 发表于 2020-1-11 20:36
里面还有个问题,SA的组合是通过检测下一个SA的行号来实现的,而最后一个SA并没有下一个SA,因此最后一个 ...

看你给出的结果,以为你不要最后的组合。
如果要,可以在末尾加上一个:
nRow = Range("b1048576").End(xlUp).Row+1
Arr = Range("b1:b" & nRow).Value
Arr(nrow,1)="SA."
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

关注官方微信,高效办公专列,每天发车

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

GMT+8, 2020-4-1 04:40 , Processed in 0.084565 second(s), 21 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2020 Wooffice Inc.

   

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

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

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