excel - 您如何修复计数 1 太多的 VBA 代码？

Question

我编写了一个程序来计算空(已验证)、空(未验证)和不可访问(已锁定)的 bin。
我正在尝试计算从我的 Bin Conversions 表中锁定的 bin，如果它们为真(有 20 个为真)，那么它们被锁定并将计入我的 Bin Report 表中。
我的 Bin Reports 表对每个组计数 1 太多(所有组总共 23 个而不是 20 个)。一个组示例是 4-Pallet、2.5 英尺、2 个锁定的箱子(而不是 1 个)。
斌报告

二进制转换

Sub getBinStatusArray()
calc (False)

Dim dSH As Worksheet
Dim brSH As Worksheet
Dim bcSH As Worksheet
Set dSH = ThisWorkbook.Sheets("data")
Set brSH = ThisWorkbook.Sheets("Bin Report")
Set bcSH = ThisWorkbook.Sheets("Bin Conversions")

Dim binLockCell As Byte, binType As String, binSize As Variant, binLocked As Boolean, b As Long, i As Long
Dim dataArray() As Variant

Dim binIDArray As Variant

'Create empty array cells
ReDim Preserve dataArray(1 To dSH.Range("A" & Rows.Count).End(xlUp).Row, 1 To 3)

'Navigates cells
With dSH
    lastrow = .Cells(Rows.Count, 1).End(xlUp).Row
    dataArray = .Range(.Cells(lastrow, 1), .Cells(1, 
    .Columns.Count).End(xlToLeft)).Value
End With

'Count Bin Conversion Cells
With bcSH
    lastrow = .Cells(Rows.Count, 1).End(xlUp).Row
    For i = 2 To lastrow
        .Range("E" & i).Value2 = Application.WorksheetFunction.CountIf(dSH.Range("A:A"), .Range("A" & i).Value2)
    Next i
End With

'Generate Bin Report
With brSH
    .Cells.ClearContents
    .Range("H1").Value = "Filter Input"
    .Range("B1").Value = "Bin Type"
    .Range("I1").Value = "Bin Type"
    .Range("C1").Value = "Bin Height"
    .Range("J1").Value = "Bin Height"
    .Range("D1").Value = "Verified"
    .Range("K1").Value = "Verified"
    .Range("E1").Value = "Unverified"
    .Range("L1").Value = "Unverified"
    .Range("F1").Value = "Bins Locked"
    .Range("M1").Value = "Bins Locked"
    
    For i = 2 To lastrow
        If bcSH.Range("E" & i).Value = 1 Or Application.WorksheetFunction.CountIfs(bcSH.Range("G" & i), "true") Then
            binType = bcSH.Range("B" & i).Value
            binSize = bcSH.Range("C" & i).Value
            binLocked = bcSH.Range("H" & i).Value
        
            If .Range("b2") = "" Then
                .Range("b2").Value = bcSH.Range("B" & i).Value
                .Range("c2").Value = bcSH.Range("C" & i).Value
                .Range("F2").Value2 = Application.WorksheetFunction.CountIfs(bcSH.Range("G" & i), "true")
        
            ElseIf .Range("b2") <> "" Then
                lastrow = brSH.Cells(Rows.Count, 2).End(xlUp).Row
                For b = 2 To lastrow + 1
                    If brSH.Range("B" & b) = binType And brSH.Range("C" & b) = binSize Then
                        brSH.Range("D" & b) = brSH.Range("D" & b) + bcSH.Range("E" & i)
                        binLockCell = Application.WorksheetFunction.CountIfs(bcSH.Range("G" & i), "true")
                        brSH.Range("F" & b) = binLockCell + brSH.Range("F" & b)
                        Exit For
                
                    ElseIf b = lastrow Then
                        .Range("b" & b + 1).Value = bcSH.Range("B" & i).Value
                        .Range("c" & b + 1).Value = bcSH.Range("c" & i).Value
                        .Range("D" & b + 1).Value = bcSH.Range("E" & i).Value
                        binLockCell = Application.WorksheetFunction.CountIfs(bcSH.Range("G" & i), "true")
                        .Range("F" & b + 1) = binLockCell + .Range("F" & b + 1)
                    End If
                Next b
               
            End If

        End If

    Next i

    Range("b1").CurrentRegion.sort key1:=Range("b1"), order1:=xlAscending, _
      key2:=Range("C1"), order2:=xlAscending, Header:=xlYes
End With
calc (True)
End Sub

Answer 1

您正在循环播放 For b = 2 To lastrow + 1但在 b = lastrow 时添加新行即在循环结束之前。所以在最后一次迭代时 b = lastrow + 1它再次总结了记录。一种解决方法是使用标志。

 ElseIf .Range("b2") <> "" Then
        Dim bExists: bExists = False
        lastrow = brSH.Cells(Rows.Count, 2).End(xlUp).Row
        ' increment existing
        For b = 2 To lastrow
            If brSH.Range("B" & b) = binType And brSH.Range("C" & b) = binSize Then
                    brSH.Range("D" & b) = brSH.Range("D" & b) + bcSH.Range("E" & i)
                    binLockCell = Application.WorksheetFunction.CountIfs(bcSH.Range("G" & i), "true")
                    brSH.Range("F" & b) = binLockCell + brSH.Range("F" & b)
            bExists = True
            Exit For
        Next b
        ' or add new line
        If Not bExists Then
            .Range("b" & b + 1).Value = bcSH.Range("B" & i).Value
            .Range("c" & b + 1).Value = bcSH.Range("c" & i).Value
            .Range("D" & b + 1).Value = bcSH.Range("E" & i).Value
            binLockCell = Application.WorksheetFunction.CountIfs(bcSH.Range("G" & i), "true")
            .Range("F" & b + 1) = binLockCell + .Range("F" & b + 1)
        End If
        
    End If