vba - VBA 根据父项数量乘以子项数量
问题描述
我正在使用表示为 ITEM_NO 的分支层次结构,其中“1.2”是“1”的第二个孩子,因为没有进一步的继承(这个“1”是最顶层的父级)。我有一个能够找到子父关系并将某个值从父行复制到子行的代码。
Sub subgroup()
'Disable screen update
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'Main function
Dim i As Long
Dim LastRow As Long
Dim subgroup As String
Dim parent As String
With Worksheets("BOM")
LastRow = .Cells(.Rows.Count, 5).End(xlUp).Row
For i = 2 To LastRow
If i = 2 Then
subgroup = .Cells(i, 3).Value
parent = getParent(.Cells(i, 10))
ElseIf Left(.Cells(i, 10), Len(parent)) <> parent Then
subgroup = .Cells(i, 3).Value
parent = getParent(.Cells(i, 10))
Else
.Cells(i, 3).Value = subgroup
End If
Next i
End With
'Enable screen update
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Function getParent(cell As Range) As String
If Not InStr(1, cell.Value, ".") Then
getParent = cell.Value
Else
getParent = Split(cell, ".")(0) & "." & Split(cell.Value, ".")(1)
End If
End Function
现在我试图弄清楚如何修改它,以便将“I”列中的子 QTY 乘以它的父 QTY,但是子父级别出现了很多次。因此,如果 "child 1.2.1"QTY=1
与 "child 1.2" 相乘QTY=2
,现在是 "child 1.2.1" QTY=1*2=2
,我们再往上一层,看到 "child 1 QTY=3
so now initial "child 1.2.1" QTY=2*3=6
。我需要可能从下到上对表格中的每一行执行此操作,因为它始终按自上而下的顺序排列,并且每个 ITEM_NO 始终是唯一的。
这是一个示例图像:
我用不同的颜色填充了每个遗产级别。所以在这个例子中,每个黄色行的数量必须乘以红色的数量,然后乘以灰色的行。同样,红色行乘以灰色行。
有人可以帮我吗?
解决方案
使用 K 列中的以下公式生成新数量,如下所示:
自下而上计算
=IFERROR(INDEX(I:I,MATCH(LEFT(J:J,FIND("#",SUBSTITUTE(J:J,".","#",LEN(J:J)-LEN(SUBSTITUTE(J:J,".",""))))-1),J:J,0))*I:I,I:I)
从上到下计算
=IFERROR(IF(INDEX(L:L,MATCH(LEFT(J:J,FIND("#",SUBSTITUTE(J:J,".","#",LEN(J:J)-LEN(SUBSTITUTE(J:J,".",""))))-1),J:J,0))="", INDEX(I:I,MATCH(LEFT(J:J,FIND("#",SUBSTITUTE(J:J,".","#",LEN(J:J)-LEN(SUBSTITUTE(J:J,".",""))))-1),J:J,0)),INDEX(L:L,MATCH(LEFT(J:J,FIND("#",SUBSTITUTE(J:J,".","#",LEN(J:J)-LEN(SUBSTITUTE(J:J,".",""))))-1),J:J,0)))*I:I,I:I)
公式有什么作用?
例如对于1.5.3.10
LEFT(J:J,FIND("#",SUBSTITUTE(J:J,".","#",LEN(J:J)-LEN(SUBSTITUTE(J:J,".",""))))-1)
剥离最后一组所以你得到1.5.3
MATCH( …[1]… ,J:J,0)
与列 J匹配1.5.3
以获取行号1.5.3
INDEX(I:I, …[2]…)
获取2
匹配找到的行号的第 I 列中的值*I:I
并将它与当前行的第 I 列的值相乘,所以2*2=4
IFERROR(…)
只返回当前行的第 I 列的值。因为1.5
它会剥离1
并试图找到它无法找到的它。因此,如果没有父项可重复使用,请保持数量相同。
现在这是公式技术。如果你真的需要在 VBA 中这样做,你可以这样做:
因此我会将 的数据读I:J
入一个数组,使用WorksheetFunctions
公式中的所有计算,将结果保存在另一个数组中并写入结果数组回到专栏I
。
Option Explicit
Public Sub TopToBottomCalculation()
Dim ws As Worksheet 'define worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim LastRow As Long 'find last row with data in column I
LastRow = ws.Cells(ws.Rows.Count, "I").End(xlUp).Row
Dim ArrQty() As Variant 'read quantity into array
ArrQty = ws.Range("I2", "I" & LastRow).Value
Dim ArrItm() As Variant 'read item no into array
ArrItm = ws.Range("J2", "J" & LastRow).Value
Dim iRow As Long
For iRow = LBound(ArrQty, 1) To UBound(ArrQty, 1)
Dim ParentItem As String 'get parent item number
Dim LastDotPosition As Long
LastDotPosition = InStrRev(ArrItm(iRow, 1), ".")
If LastDotPosition > 0 Then 'if no dot was found there is no parent
ParentItem = Left$(ArrItm(iRow, 1), LastDotPosition - 1)
Dim ParentMatch As Double
ParentMatch = 0 'initialize because in loop
On Error Resume Next 'next line throws error if no parent item is found
ParentMatch = Application.WorksheetFunction.Match(ParentItem, ArrItm, 0)
On Error GoTo 0 're-enable error reporting
If Not ParentMatch = 0 Then 'if there was a parent item multiplicate current quantity with parent quantity
ArrQty(iRow, 1) = ArrQty(iRow, 1) * ArrQty(ParentMatch, 1)
End If
End If
Next iRow
'write array quantity back to cells
ws.Range("I2").Resize(RowSize:=UBound(ArrQty, 1)).Value = ArrQty
End Sub
// 根据评论编辑
为了能够像存在 a1
和 a1.2.3
但 no那样跳转不存在的父母,那么即使没有 ,以下1.2
代码仍将乘以。1.2.3
1
1.2
match
请注意,如果您混合数字和字符串,总是会出现问题。因此,请确保您的所有项目编号都以字符串形式输入,否则匹配将失败并且计算错误。因此,如果您有1
作为项目编号,请确保输入它,因为'1
撇号不会显示,但确保1
是文本而不是数字,因此匹配可以正常工作。
Option Explicit
Public Sub TopToBottomCalculation()
Dim ws As Worksheet 'define worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim LastRow As Long 'find last row with data in column I
LastRow = ws.Cells(ws.Rows.Count, "I").End(xlUp).Row
Dim ArrQty() As Variant 'read quantity into array
ArrQty = ws.Range("I2", "I" & LastRow).Value
Dim ArrItm() As Variant 'read item no into array
ArrItm = ws.Range("J2", "J" & LastRow).Value
Dim iRow As Long
For iRow = LBound(ArrQty, 1) To UBound(ArrQty, 1)
Dim ParentItem As String 'get parent item number
Dim CurrentItem As String
CurrentItem = ArrItm(iRow, 1)
Dim LastDotPosition As Long
LastDotPosition = InStrRev(CurrentItem, ".")
Dim ParentMatch As Double
ParentMatch = 0 'initialize because in loop
Do While LastDotPosition > 0 And ParentMatch = 0 'loop through parent levels until parent is found or no parent exists
ParentItem = Left$(CurrentItem, LastDotPosition - 1)
ParentMatch = 0 'initialize because in loop
On Error Resume Next 'next line throws error if no parent item is found
ParentMatch = Application.WorksheetFunction.Match(ParentItem, ArrItm, 0)
On Error GoTo 0 're-enable error reporting
If Not ParentMatch = 0 Then 'if there was a parent item multiplicate current quantity with parent quantity
ArrQty(iRow, 1) = ArrQty(iRow, 1) * ArrQty(ParentMatch, 1)
Else 'if parent item did not match then try to find the next upper level parent item
CurrentItem = ParentItem
LastDotPosition = InStrRev(CurrentItem, ".")
End If
DoEvents
Loop
Next iRow
'write array quantity back to cells
ws.Range("I2").Resize(RowSize:=UBound(ArrQty, 1)).Value = ArrQty
End Sub
推荐阅读
- angular - Angular 4+ Firebase Visual Sutudio Online Azure CI 构建错误
- c# - 转换时输入字符串的格式不正确,将值插入循环内的数据库
- sql - SQL Server Management Studio 需要完整的表路径
- django - DjangoForm 类元覆盖
- excel - 如何明智地使用高级过滤行
- excel - 想要一个包含非连续单元格的命名列表
- javascript - '[nodemon] 应用程序崩溃 - 在开始之前等待文件更改......'
- java - RESTful 重定向到基于单选按钮选择的路径
- android - 第二个动画从屏幕顶部开始,而不是前一个动画的位置
- android - 在 adb shell 中选择选项卡式数据而不使用 awk,因为使用 awk 会出现“awk not found error”