自动创建组 [英] Automating group creation
问题描述
我正在尝试编写一个脚本,以便从从SAP导出的数据中自动创建组。因此,数据在第一列中列出如下,部分号码和描述如下。
.1
..2
..2
... 3
.... 4
.1
.1
..2
等等,其中 1
是最高的级别和 4
最低原材料级别可以是每个子级别中的每一个或数百个之一。只有一个出口有2,000-5,000个组件,所以这是一个非常繁琐的过程,从手动分组一切。所以我一直在尝试自动化,但是一直跑到墙上。我的代码是一团糟,除了我会发布我所做的一切以外,我没有任何事情。
Dim myRange As范围
Dim rowCount As Integer,currentRow As Integer
Dim GrpRange As Range,GrpStart As Integer,GrpEnd As Integer,GrpCount As Integer
Dim GrpLoop As Integer,GrpLoopEnd As Integer,GrpLoopEndRow As Integer
Dim GrpSt As Integer
GrpSt = 2
GrpStart = 2
GrpEnd = RowEnd(2,1)
GrpLoopEnd = 100
'循环遍历每个组
'对于TotalLoop = 2 To GrpEnd
'确定1到1行长度
对于GrpStart = GrpSt到GrpEnd
单元格(GrpStart ,1)。选择
如果右(ActiveCell,1)= 1然后
GrpSt = ActiveCell.Row
对于GrpLoop = 0到GrpLoopEnd
如果右(Cells(GrpSt,1 ),1)= 1然后
GrpLoopEnd = 1
GrpLoopEndRow = ActiveCell.Row
退出
结束如果
Next
End If
Next GrpStart
我是第一个只是试图找到每个顶级 1
和下一个之间的长度,因为有时有结构,有时不是。接下来,我将为 2
然后 3
然后 4
在一个组中,然后进行分组,最后循环遍历列的其余部分,并对每个1到1组执行相同操作。我不知道这是否是正确的方式,甚至可能,但是我必须从某个地方开始。
以下是导出内容的示例:
以下是我正在寻找的分组示例:
尝试此代码:
Sub AutoOutline_Characters()
/ pre>
Dim intIndent As Long,lRowLoop2 As Long,lRowStart As Long
Dim lLastRow As Long,lRowLoop As Long
Const sCharacter As String =。
application.ScreenUpdating = False
单元格(1,1).CurrentRegion.ClearOutline
lLastRow =单元格(Rows.Count,1)。结束(xlUp).Row
With ActiveSheet.Outline
.AutomaticStyles = False
.SummaryRow = xlAbove
.SummaryColumn = xlRight
End with
对于lRowLoop = 2 To lLastRow
intIndent = IndentCalc(Cells(lRowLoop,1).Text,sCharacter)
如果IndentCalc(Cells(lRowLoop + 1,A),sCharacter)< = intIndent然后GoTo nxtCl:
对于lRowLoop2 = lRowLoop + 1 To lLastRow'为我们当前单元格下面的所有行
如果IndentCalc(Cells(lRowLoop2 + 1,A),sCharacter)< = intIndent和lRowLoop2> lRowLoop + 1然后'如果遇到更高的维度
如果lRowLoop2> lRowLoop + 1 Then Rows(lRowLoop + 1&:& lRowLoop2).Group
GoTo nxtCl
End If
Next lRowLoop2
nxtCl:
下一个lRowLoop
application.ScreenUpdating = True
End Sub
函数IndentCalc(sString As String, (sString)
如果Mid > sCharacter Then
IndentCalc = lCharLoop - 1
退出函数
结束如果
下一个
结束函数
I'm trying to write a script to automate creating groups from data being exported from SAP. So the data comes out as follows in the first column with part numbers and descriptions in the following ones.
.1 ..2 ..2 ...3 ....4 .1 .1 ..2
and so on and so forth with
1
being the highest level and4
the lowest raw material level there can be one of each or hundreds of each sub-level. Just one export has 2,000-5,000 components so it's a very tedious process starting out with grouping everything manually. So I've been trying to automate this but keep running into walls. My code is a mess and doesn't really do anything but I'll post what I've done.Dim myRange As Range Dim rowCount As Integer, currentRow As Integer Dim GrpRange As Range, GrpStart As Integer, GrpEnd As Integer, GrpCount As Integer Dim GrpLoop As Integer, GrpLoopEnd As Integer, GrpLoopEndRow As Integer Dim GrpSt As Integer GrpSt = 2 GrpStart = 2 GrpEnd = RowEnd(2, 1) GrpLoopEnd = 100 'Loop through each group 'For TotalLoop = 2 To GrpEnd 'Determine 1 to 1 row length For GrpStart = GrpSt To GrpEnd Cells(GrpStart, 1).Select If Right(ActiveCell, 1) = 1 Then GrpSt = ActiveCell.Row For GrpLoop = 0 To GrpLoopEnd If Right(Cells(GrpSt, 1), 1) = 1 Then GrpLoopEnd = 1 GrpLoopEndRow = ActiveCell.Row Exit For End If Next End If Next GrpStart
I'm first just trying to find the length between each top level
1
and the next one, because sometimes there is structure and sometimes not. Next I was going to do the same for the2
then3
then4
within that one "group", then do the grouping and finally loop through the rest of the column and do the same with each "1 to 1" group. I'm not sure if this is the right way or even possible but I had to start from somewhere.Here's an example of what is exported:
Here's an example of the grouping I'm looking for:
解决方案Try this code:
Sub AutoOutline_Characters() Dim intIndent As Long, lRowLoop2 As Long, lRowStart As Long Dim lLastRow As Long, lRowLoop As Long Const sCharacter As String = "." application.ScreenUpdating = False Cells(1, 1).CurrentRegion.ClearOutline lLastRow = Cells(Rows.Count, 1).End(xlUp).Row With ActiveSheet.Outline .AutomaticStyles = False .SummaryRow = xlAbove .SummaryColumn = xlRight End With For lRowLoop = 2 To lLastRow intIndent = IndentCalc(Cells(lRowLoop, 1).Text, sCharacter) If IndentCalc(Cells(lRowLoop + 1, "A"), sCharacter) <= intIndent Then GoTo nxtCl: For lRowLoop2 = lRowLoop + 1 To lLastRow 'for all rows below our current cell If IndentCalc(Cells(lRowLoop2 + 1, "A"), sCharacter) <= intIndent And lRowLoop2 > lRowLoop + 1 Then 'if a higher dimension is encountered If lRowLoop2 > lRowLoop + 1 Then Rows(lRowLoop + 1 & ":" & lRowLoop2).Group GoTo nxtCl End If Next lRowLoop2 nxtCl: Next lRowLoop application.ScreenUpdating = True End Sub Function IndentCalc(sString As String, Optional sCharacter As String = " ") As Long Dim lCharLoop As Long For lCharLoop = 1 To Len(sString) If Mid(sString, lCharLoop, 1) <> sCharacter Then IndentCalc = lCharLoop - 1 Exit Function End If Next End Function
这篇关于自动创建组的文章就介绍到这了,希望我们推荐的答案对大家有所帮助,也希望大家多多支持IT屋!