用vba使科目余额表按字符长度分级显示

asdfghjklzz · 发表于 2020-1-10 02:20

本帖最后由 asdfghjklzz 于 2020-1-10 02:27 编辑

按字符长度分级显示

前四位为一级
56位一级
78位一级
9，10位一级
11，12一级

不要分类汇总，不要函数，我都试过了，想试试vba

让表一变成表二的效果。
最好注释一下部分代码含义，可以让我也学习一下

之前看过的类似帖子，但是达不到我要的效果，我也不会调整代码，只能请大神帮帮忙了！

按序号为分级显示自动创建组按分级显示的组合自动编序号

http://club.excelhome.net/thread-1098513-1-1.html
这个链接的9楼，楼主写的代码可以研究一下
楼主的附件我也放上来

microyip · 发表于 2020-1-10 08:54

不要这个，不要那个……好强势哦
注释代码，学习……那你不是从基础学起
达不到效果，不会调整代码……那就是伸手党咯

asdfghjklzz · 发表于 2020-1-10 09:37

本帖最后由 asdfghjklzz 于 2020-1-10 09:43 编辑

microyip 发表于 2020-1-10 08:54
不要这个，不要那个……好强势哦
注释代码，学习……那你不是从基础学起
达不到效果，不会调整代码……那 ...

我才刚开始学习vba，也找了书在看，但是vba不是能一朝一夕学会的，我还在上班，平时也是闲暇的时候才能学习。

这个是为了工作上的方便，我要的比较着急，也不可能放下工作专门学习vba

我也在网上找过了，但是只有这位老师的代码能显示分级，没有专门学过我也不会修改代码，我调试了一天，调到晚上两点，实在是做不到才放到论坛上来，希望有老师能帮我一下

在工作中才能学习到新知识才能进步，我在之前也没有想到会用到分级啊。
让老师注释一下，我理解了以后就是学会了一个新知识啊
论坛不就是为了大家方便学习，使人进步吗？

如果您会这个题目的话，还望不吝指教！

microyip · 发表于 2020-1-10 09:47

“为了大家方便学习，使人进步吗？”是你学习了基础知识，在处理事务时遇到什么问题，协助解决，使你进步。正如你自己说，“我不会调整”，你连基础知识都没有，你能会？别人写了给你，你还是不会啊，但会达到你的目的，“我能用了”

asdfghjklzz · 发表于 2020-1-10 10:01

microyip 发表于 2020-1-10 09:47
“为了大家方便学习，使人进步吗？”是你学习了基础知识，在处理事务时遇到什么问题，协助解决，使你进步。 ...

现在是达到了我暂时的目的，但是能说以后不会有人也来找这个问题吗？
我已经提出的问题，就算没有达到别人的要求，起码是一个思路。
就像上一位老师一样，他开启了我的思路，但很可惜我不太会代码。所以只能另开一贴寻求帮助

microyip · 发表于 2020-1-10 10:04

asdfghjklzz 发表于 2020-1-10 10:01
现在是达到了我暂时的目的，但是能说以后不会有人也来找这个问题吗？
我已经提出的问题，就算没有达到别 ...

正如你列举的案例，你应该去学习啊，然后理解啊，再修改为你需要的。

asdfghjklzz · 发表于 2020-1-10 10:23

microyip 发表于 2020-1-10 10:04
正如你列举的案例，你应该去学习啊，然后理解啊，再修改为你需要的。

也如我之前说的一样，我的工作让我觉得我现在就需要这个代码，我开始查找这个代码，但是没有结果。

我的工作时间又不允许我从基础知识学起，我也说了平时会找代码多看看，但是在如此紧急的时间我不可能放下手上的工作开始从头学习

从开始真正接触表格到现在有两个月的时间，比起在论坛的各位，我知道excel的功能如此强大就在不久之前，接触函数之后才开始了解代码，才开始学习基础知识

我平时还要上班，闲暇之余才有时间学习代码，但是再怎么学习，我都没办法在这么短的时间内，能做到直接修改代码，我现在能理解的代码都只是最最基础的批处理文件夹之类。

所以如果您知道如何修改的话，还望不吝指教！

microyip · 发表于 2020-1-10 10:29

asdfghjklzz 发表于 2020-1-10 10:23
也如我之前说的一样，我的工作让我觉得我现在就需要这个代码，我开始查找这个代码，但是没有结果。

我 ...

既然只是赶住完成工作，那么还不要这个不要那个干嘛，能完成就好啦。反正不是因为要学习，而是为了完成工作

yjh_27 · 发表于 2020-1-10 11:15

参见
BOM 大纲排序-自定义函数
http://club.excelhome.net/thread-1175717-1-1.html
(出处: ExcelHome技术论坛)

看懂，会修改sub aa 即可
各调用参数见模块代码注释

lsdongjh · 发表于 2020-1-10 11:44

Option Explicit
Sub Test()
Dim shData As Worksheet, arrGroup As Variant
Dim lngRow As Long, strTemp As String, lngID As Long
Dim lngLevMax As Long, lngLevMin As Long
Set shData = Sheets("Sheet1")
shData.UsedRange.ClearOutline
lngRow = shData.Range("A" & Rows.Count).End(xlUp).Row
arrGroup = shData.Range("A1:A" & lngRow)
'根据规则，将数据转为层级
'前四位为一级
'56 位一级
'78 位一级
'9，10位一级
'11，12一级
For lngRow = LBound(arrGroup) + 1 To UBound(arrGroup)
strTemp = Trim(arrGroup(lngRow, 1))
lngID = (Len(strTemp) - 4) / 2 + 1
If lngID < 0 Then lngID = 0
arrGroup(lngRow, 1) = lngID
Next
'最大、最小层级
lngLevMax = Application.WorksheetFunction.Max(arrGroup)
lngLevMin = Application.WorksheetFunction.Min(arrGroup)
Application.ScreenUpdating = False
Application.Cursor = xlWait
'最小层级不用处理，默认为顶级
For lngID = lngLevMax To lngLevMin + 1 Step -1
GroupByLevID shData, arrGroup, lngID
Next
Application.ScreenUpdating = True
Application.Cursor = xlDefault
MsgBox "OK"
End Sub
Function GroupByLevID(sh As Worksheet, ByRef arrID As Variant, lngLevID As Long)
Dim lngStartID As Long, lngEndID As Long, lngRow As Long
'首行为标题
For lngRow = LBound(arrID) + 1 To UBound(arrID)
'是否为所查找的层级
If arrID(lngRow, 1) = lngLevID Then
'如果找到该层级，判断是否为第一次
If lngStartID = 0 Then
'如果是刚找到，起始、结束赋值
lngStartID = lngRow
lngEndID = lngRow
arrID(lngRow, 1) = lngLevID - 1 '将当前值减1，以便下次查找
Else
'如果是起始值已赋值，更改结束值
lngEndID = lngRow
arrID(lngRow, 1) = lngLevID - 1 '将当前值减1，以便下次查找
End If
Else
'如果不是当前层级，判断是否有起始值
If lngStartID > 0 Then
sh.Rows(lngStartID & ":" & lngEndID).Group
lngStartID = 0: lngEndID = 0
End If
End If
'最后一行处理
If lngRow = UBound(arrID) And lngStartID > 0 Then
sh.Rows(lngStartID & ":" & lngEndID).Group
lngStartID = 0: lngEndID = 0
End If
Next
End Function

复制代码

		自动登录	找回密码
密码			免费注册

用vba使科目余额表按字符长度分级显示

评分

评分