如何按层级数将数据自动分组

qymjessy · 发表于 2018-4-23 09:23

求教一个问题：我的数据是按照比较规范的格式进行分级排列（如A列），我现在可以使用填加辅助列的办法（如C列）将这些数据自动分组。有没有办法可以参照层级数（如D列）将这些数据自动分组呢？
多谢各位帮忙~

一把小刀闯天下 · 发表于 2018-4-23 09:56

Option Explicit

Sub test()
  Dim i, j, arr, flag
  With Sheets("sheet1")
arr = .Range("a1:a" & .Cells(Rows.Count, "a").End(xlUp).Row + 1)
ReDim brr(1 To UBound(arr, 1), 1 To 1)
For i = 2 To UBound(arr, 1) - 1
   flag = False
   For j = i + 1 To UBound(arr, 1)
      If InStr(arr(j, 1), arr(i, 1)) = 1 Then flag = True
      If InStr(arr(j, 1), arr(i, 1)) = 0 Then
      If flag Then brr(i, 1) = i + 1 & "->" & j - 1
      Exit For
      End If
Next j, i
.[e1].Resize(UBound(brr, 1)) = brr
  End With
End Sub

qymjessy · 发表于 2018-4-23 10:54

一把小刀闯天下发表于 2018-4-23 09:56
Option Explicit

Sub test()

多谢！我去学习一下！

qymjessy · 发表于 2018-5-2 16:37

一把小刀闯天下发表于 2018-4-23 09:56
Option Explicit

Sub test()

您好~由于出差一直没办法仔细研究，我今天才发现一个问题：虽然可以在E列生成级别的代号，但是我把原来的辅助列（即用公式表达分组）删除以后，自动分级显示也就不好使了，这没达到我的初衷，我是想按“层级”列实现自动分级，麻烦您再看看怎么回事，多谢~

jiaxinl · 发表于 2018-5-28 11:34

qymjessy 发表于 2018-5-2 16:37
您好~由于出差一直没办法仔细研究，我今天才发现一个问题：虽然可以在E列生成级别的代号，但是我把原来的 ...

'===============================================================================
'堆栈在树形结构中使用的实例
'-------------------------------------------------------------------------------
'本实例实现一下功能:
'(1) 按树形结构设置Excel的数据分组及分级显示
'(2) 使用方框与连接线绘制树形，类似TreeView效果
'-------------------------------------------------------------------------------
'原始数据中，有全部数形结构数据，各节点可有重复的编号、能指示节点所在级数的符号、节点的名称、
'-------------------------------------------------------------------------------
'本代码采用字典对象模拟堆栈，对原始数据循环扫描完成绘制树形图，
'可学习到堆栈、字典对象、结构图绘制、数据分组分级显示内容
'本实例可应用于材料列表（BOM）的统计、公司结构绘制等多种实践。
'===============================================================================
Const TR_LEVEL_MARK = "." '分级标记符
Const TR_COL_LEVEL = "A" '分级标记列
Const TR_COL_INDEX = "B" '物料编码列
Const TR_COL_NAME = "B" '"C" '物料名称列
Const TR_COL_TREE_START = "F" '树形图开始列
Const TR_ROW_HEIGHT = 20 '行高
Const TR_COL_LINE_WIDTH = 3 '树形线宽
Const TR_COL_BOX_MARGIN = 2 '树形框边缘
Sub CalculationAndDrawTree()
Dim iMaxRow&, i&, j&, dic, dic_x, aKeys, iLevelLast%, iLevelNow%
Undo_All '全部恢复
Application.ScreenUpdating = False
iMaxRow = Cells(65536, 1).End(xlUp).Row '最大行号
Rows("1:" & iMaxRow).RowHeight = TR_ROW_HEIGHT '设置行高
iLevelLast = 0 '初始前一节点的级数
Set dic = CreateObject("Scripting.Dictionary") '设置字典对象以模拟堆栈，Key为行号，Item为对应的级数。
Set dic_x = CreateObject("Scripting.Dictionary") '设置字典对象,Key为物料编码，Item为对应的个数。目的是为处理物料编码有重复的情况
For i = 2 To iMaxRow + 1 '从数据起始行开始始到数据结尾行加一为止循环，多一行以收尾堆栈内最后剩余的节点
dic_x(Range(TR_COL_INDEX & i).Value) = dic_x(Range(TR_COL_INDEX & i).Value) + 1 '处理物料编码有重复的情况,进行计数
If dic_x(Range(TR_COL_INDEX & i).Value) = 1 Then '当物料编码第一次出现时
ssName = Cells(i, TR_COL_INDEX).Text '节点框名称==>物料编码
Else
ssName = Cells(i, TR_COL_INDEX).Text & "_" & dic_x(Range(TR_COL_INDEX & i).Value) '节点框名称+序号
End If
If i = iMaxRow + 1 Then '当等于最大行+1时
iLevelNow = 0 '级数为0
Else
iLevelNow = UBound(Split(Range(TR_COL_LEVEL & i), TR_LEVEL_MARK)) + 1 '获得当前节点级数，此例用A列分级标记符(".")数量判断
Rows(i).OutlineLevel = iLevelNow '设置当前行的大纲级数
End If
If dic.Exists(i - 1) Then '如果前一节点在堆栈内，且前一节点级数同当前节点，则将前一节点从堆栈内删除
If dic(i - 1) = iLevelNow Then dic.Remove i - 1
End If
'判断当前节点和前一节点的级数关系
If iLevelNow > iLevelLast Then '当前节点级数大于前一节点，将当前节点压入堆栈
dic(i) = iLevelNow
If i > 2 Then dic(i - 1) = UBound(Split(Range(TR_COL_LEVEL & i - 1), TR_LEVEL_MARK)) + 1 '目的是处理同一级中层级数混合时(如：++，++，+++)的情况画树形线
ElseIf iLevelNow < iLevelLast Then '当前节点级数小于前一节点，将堆栈内大于等于当前节点级数的项有堆栈顶开始逐一弹出
aKeys = dic.keys '获得堆栈内记录的行号赋值给数组
For j = UBound(aKeys) To LBound(aKeys) Step -1 '由堆栈顶开始向堆栈底循环
If dic(aKeys(j)) < iLevelNow Then Exit For '当循环至记录的级数小于当前节点级数则退出循环
dic.Remove aKeys(j) '删除堆栈顶部项目
Next
dic(i) = iLevelNow '将当前节点压入堆栈
End If
iLevelLast = iLevelNow '记录当前节点为前一节点，供下一个循环使用
'绘制当前节点框，并与父节点绘制连接线
If i < iMaxRow + 1 Then DrawLevelBoxAndLine i, iLevelNow, dic, dic_x, ssName
Next i
'清空字典项并重置对象
dic.RemoveAll: dic_x.RemoveAll: Set dic = Nothing: Set dic_x = Nothing
'设置大纲项目的汇总行在上方
With Outline
.AutomaticStyles = False
.SummaryRow = xlAbove
.SummaryColumn = xlRight
End With
Application.ScreenUpdating = True
End Sub
Sub DrawLevelBoxAndLine(iRow, iLevel, dic, dic_x, ssName) '绘制树形框和连接线
Dim iCol&, nLeft!, nTop!, nWidth!, nHeight!, iParent&, aKeys, sName$, sParentName$
iCol = Columns(TR_COL_TREE_START).Column + (iLevel - 1) * 2 '计算绘图区起始列号
Columns(iCol - 1).ColumnWidth = TR_COL_LINE_WIDTH '设置连接线所在列列宽
Columns(iCol).ColumnWidth = Cells(1, TR_COL_NAME).ColumnWidth + TR_COL_LINE_WIDTH '设置节点框所在列宽
With Cells(iRow, iCol) '计算节点框位置和大小
nTop = .Top + TR_COL_BOX_MARGIN / 2
nLeft = .Left + TR_COL_BOX_MARGIN / 2
nWidth = .Width - TR_COL_BOX_MARGIN
nHeight = .Height - TR_COL_BOX_MARGIN
End With
sName = ssName '获得节点框名称
With Shapes.AddShape(msoShapeRectangle, nLeft, nTop, nWidth, nHeight) '绘制节点框
.TextFrame.Characters.Text = Cells(iRow, TR_COL_NAME).Text '节点框内容为节点名称
.Name = sName '设置节点框名为节点物料编码 (已处理有重复的情况)
.ShapeStyle = msoShapeStylePreset35
End With
If dic.Count = 0 Then Exit Sub '如果堆栈内为空，则退出（不用画连接线）
aKeys = dic.keys '获得堆栈内记录的行号赋值给数组
If iRow = aKeys(UBound(aKeys)) Then '判断堆栈内最后一个节点与当前节点关系
If UBound(aKeys) = 0 Then Exit Sub '如果堆栈内最后节点同当前节点，且堆栈仅余一个节点，则退出（不用画连接线）
iParent = aKeys(UBound(aKeys) - 1) '如果堆栈内最后节点同当前节点，则堆栈内倒数第二个节点为父节点
Else
iParent = aKeys(UBound(aKeys)) '如果堆栈内最后节点不同于当前节点，则堆栈内最后节点为父节点
End If
'获得父节点框名称
If dic_x(Cells(iParent, TR_COL_INDEX).Text) = 1 Then '当物料编码第一次出现时
sParentName = Cells(iParent, TR_COL_INDEX).Text '节点框名称==>物料编码
Else
sParentName = Cells(iParent, TR_COL_INDEX).Text & "_" & dic_x(Cells(iParent, TR_COL_INDEX).Text) '节点框名称+序号 '目的是为处理物料编码有重复的情况
End If
With Shapes(sParentName) '计算连接线位置和大小
nLeft = .Left + .Width
nTop = .Top + .Height / 2
nWidth = nLeft - Shapes(sName).Left
nHeight = .Top - Shapes(sName).Top
End With
With Shapes.AddConnector(msoConnectorElbow, nLeft, nTop, nWidth, nHeight) '绘制连接线
.Flip msoFlipHorizontal '水平翻转
.Flip msoFlipVertical '垂直翻转
.ConnectorFormat.BeginConnect Shapes(sParentName), 4 '起点为父节点框的第4个锚点
.ConnectorFormat.EndConnect Shapes(sName), 2 '终点为本节点框的第2个锚点
.Name = sParentName & "->" & sName '设置连接线名称父节点框->下级
.ShapeStyle = msoShapeStylePreset35
End With
End Sub
Sub Undo_All() '全部恢复
Dim i&, shp As Shape
Application.ScreenUpdating = False
With Cells
.EntireRow.AutoFit
.EntireColumn.ColumnWidth = TR_COL_LINE_WIDTH
.EntireColumn.AutoFit
.Interior.ColorIndex = xlNone
.Font.ColorIndex = 0
.ClearOutline '清除所有分级
End With
Rows(1).RowHeight = TR_ROW_HEIGHT
For Each shp In Shapes
If shp.Type <> msoFormControl Then shp.Delete
Next
Application.ScreenUpdating = True
End Sub

复制代码

fanjxgr1 · 发表于 2020-4-11 23:25

能否帮按照分类代码自动分组，分类代码的最底层8位数字

chenjx80 · 发表于 2020-4-12 17:11

在我看来，分组功能就是鸡肋，既丑陋又不实用！

也许以下这些方式能给予您启发：
链接: https://pan.baidu.com/s/1JZNfLp-0sj_wINA6bCdDaQ  提取码: fztk
链接: https://pan.baidu.com/s/1SLxDOkcLVr7oEpGrlGvCWg  提取码: enmc
链接: https://pan.baidu.com/s/10Vu9m02Egz8qpbd-Wmg9hg  提取码: ps7f

congcong1008 · 发表于 2020-11-18 09:29

jiaxinl 发表于 2018-5-28 11:34

您好，我用您的附件下载后执行，但只是对前两行进行了分组，并没有像您展示的那样对所有数据进行分组，是怎么回事呢

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

[求助] 如何按层级数将数据自动分组