VBA for / .find 循环不会跳到下一行

Question

我有一个VBA脚本，用于搜索H列中的一个值，如果同一行的D-G列中存在第二个值，它应该修改I列中的数量。如果在该行中找不到该值，则它应该继续寻找。

这对于大多数条目都适用，但在某些条目上，有太多潜在代码无法容纳在 4 列中，因此我在 H 列中具有相同值的某些部分上添加了另一行，但其余的它应该在 D-G 列中查找的值。因为脚本应该检查 H 列，找到值 1，检查 D-G 列是否有值 2，如果没有找到，则继续搜索，我认为它会继续到下一行并找到它要查找的内容。然而，事实并非如此。 如果它寻找的第二个值位于顶部，那么它可以很好地找到正确的行，但如果它位于第二行，则它找不到它。我已经包含了 Excel 工作表的片段作为示例。

Private Sub RemoveStock_Click()
 Dim EmptyRange As Range
    ThisWorkbook.Sheets("Log").Range("J1").Value = UserForm1.TextBox1.Text
    ThisWorkbook.Sheets("Log").Range("J2").Value = UserForm1.TextBox2.Text
    ThisWorkbook.Sheets("Log").Range("J3").Value = UserForm1.TextBox3.Text
    ThisWorkbook.Sheets("Log").Range("J4").Value = UserForm1.TextBox4.Text
    If ThisWorkbook.Sheets("Log").Range("J3").Value = "" Then
        MsgBox "no Quantity has been entered"
    End If
    Range("H4").Select
    
Dim BHM
Dim DT
Dim BHMrng As Range
Dim DTrng As Range
Dim rnmb
Dim cel As Range
Dim found
found = ThisWorkbook.Sheets("Log").Range("Z4").Value
BHM = ThisWorkbook.Sheets("Log").Range("J1").Value
DT = ThisWorkbook.Sheets("Log").Range("J2").Value
Range("H4").Activate
Dim x As Long
For x = 1 To 10
    On Error Resume Next
    Set DTrng = ThisWorkbook.Sheets("Inventory").Columns("H:H").Find(DT, Range("H" & ActiveCell), xlValues, xlWhole, 1, 1, 0)
    If Not DTrng Is Nothing Then
    DTrng.Activate
        For Each cel In Range(DTrng.Offset(0, -4), DTrng.Offset(0, -1))
            If cel.Value = BHM Then
            DTrng.Offset(0, 1).Value = DTrng.Offset(0, 1).Value + ThisWorkbook.Sheets("Log").Range("J3").Value
            found = "1"
            ElseIf cel.Value = "Misc." Then
            DTrng.Offset(0, 1).Value = DTrng.Offset(0, 1).Value + ThisWorkbook.Sheets("Log").Range("J3").Value
            found = "1"
            End If
            
            If found = "1" Then
            Exit For
            End If
        Next cel
        
    If found = "1" Then
    Exit For
    End If
    End If
    
Next x
If found = "" Then
MsgBox "no matching BHM for Detail #"
End If
    


If found = "1" Then
found = ""
End If

ThisWorkbook.Sheets("Log").Range("J1:J4").ClearContents
End Sub

工作表：

Answer 1

匹配

DT

值时，可以检查I列是否有合并单元格，然后在D:G列中搜索相关行

未经测试：

Private Sub RemoveStock_Click()
    
    Dim wsLog As Worksheet, wsInv As Worksheet
    Dim BHM, DT, cel As Range, found, v
    Dim r As Long, lr As Long, iColRows As Long
    
    Set wsLog = ThisWorkbook.Sheets("Log")
    Set wsInv = ThisWorkbook.Sheets("Inventory")
    
    wsLog.Range("J1").Value = Me.TextBox1.Text 'use `Me` if this code is in a userform
    wsLog.Range("J2").Value = Me.TextBox2.Text
    wsLog.Range("J3").Value = Me.TextBox3.Text
    wsLog.Range("J4").Value = Me.TextBox4.Text
    
    If wsLog.Range("J3").Value = "" Then
        MsgBox "no Quantity has been entered"
        Exit Sub '?????
    End If
    
    found = wsLog.Range("Z4").Value 'what is this for?
    BHM = wsLog.Range("J1").Value
    DT = wsLog.Range("J2").Value
    
    r = 2 'start checking here...
    lr = wsInv.Cells(Rows.Count, "H").End(xlUp).Row 'last value in col H
    
    Do While r <= lr
        If wsInv.Cells(r, "H").Value = DT Then
            iColRows = wsInv.Cells(r, "I").MergeArea.Rows.Count '?Col I is merged?
            'check each cell in (D to G) x (# of merged rows in Col I)
            For Each cel In wsInv.Cells(r, "D").Resize(iColRows, 4).Cells
                v = cel.Value
                If v = BHM Or v = "Misc." Then
                    With wsInv.Cells(r, "I")
                        .Value = .Value & wsLog.Range("J3").Value 'increment amount
                        found = "1"
                        Exit Do 'done searching...
                    End With
                End If
            Next cel
            r = r + (iColRows - 1) 'not matched, so skip to last "Extra" row before continuing the search
        End If
        r = r + 1 'increment search row
    Loop
    
    If found <> "1" Then MsgBox "no matching BHM for Detail #"

    wsLog.Range("J1:J4").ClearContents
End Sub