VBA 根据 PARENT 数量乘以 CHILD 项目数量
VBA Multiply CHILD item QTY based on PARENT QTY
我正在使用表示为 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”列中的子数量乘以它的父数量，但是子-父级别出现了很多次。因此，如果“child 1.2.1”QTY=1 乘以“child 1.2”QTY=2，现在是“child 1.2.1”QTY=1*2=2，我们再往上一层，就会看到“child 1 QTY=3 所以现在初始“child 1.2.1”QTY=2*3=6。我需要对 table 中的每一行从下到上执行此操作，因为它总是排列在自上而下的顺序，每个 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.3MATCH( …[1]… ,J:J,0) 匹配 1.5.3 与列 J 得到 1.5.3INDEX(I:I, …[2]…)获取match2
*I:I 乘以当前行第 I 列的值，所以 2*2=4IFERROR(…) 只是 returns 当前行的第 I 列的值。因为对于 1.5 它将剥离到 1 并尝试找到它不能。因此，如果没有 parent 项可重复，请保持数量不变。
这就是公式技巧。如果你真的需要在 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
// 根据评论编辑
为了能够跳转不存在的 parent，比如有 1 和 1.2.3 但没有 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
我正在使用表示为 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”列中的子数量乘以它的父数量，但是子-父级别出现了很多次。因此，如果“child 1.2.1”QTY=1 乘以“child 1.2”QTY=2，现在是“child 1.2.1”QTY=1*2=2，我们再往上一层，就会看到“child 1 QTY=3 所以现在初始“child 1.2.1”QTY=2*3=6。我需要对 table 中的每一行从下到上执行此操作，因为它总是排列在自上而下的顺序，每个 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.3MATCH( …[1]… ,J:J,0)匹配1.5.3与列 J 得到1.5.3 的行号
INDEX(I:I, …[2]…)获取match 找到的行号第I列的值*I:I乘以当前行第 I 列的值，所以2*2=4IFERROR(…)只是 returns 当前行的第 I 列的值。因为对于1.5它将剥离到1并尝试找到它不能。因此，如果没有 parent 项可重复，请保持数量不变。
2
这就是公式技巧。如果你真的需要在 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
// 根据评论编辑
为了能够跳转不存在的 parent，比如有 1 和 1.2.3 但没有 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