Excel VBA查找问题

Question

虽然我尝试过努力但没有运气，但我很擅长VBA。

问题陈述：

我有一张带有Source（颜色为白色）行和Destination（颜色为黄色）行的工作表，对于每个源，下一行中都有一个对应的目标行。 我必须在一开始查找用户输入的应用程序名称，并将在第6列中搜索整个工作表（超过10000行），如果在源行中找到它，也必须提取源行（如果在目标和目标行中找到）在sheet2中。

而且一个单元格中可能包含许多应用程序名称，因此它应该修剪该单元格中的所有其他应用程序名称，并仅保留搜索到的应用程序名称。

这是我尝试的部分代码：

Sub GetInterfaceCounts()
    Dim RANGEBOTTOM As String
    Dim cell
    Dim strAction As String
    Dim intAdd As Integer
    Dim strName As String

    intAdd = 0
    RANGEBOTTOM = "G700"
    strName = InputBox(Prompt:="Please enter the application name.", _
    Title:="Application Name", Default:="Application")

    For Each cell In Range("G2:" & RANGEBOTTOM)
        strAction = cell.Value

        If InStr(1, strAction, strName) <> 0 Then
            intAdd = intAdd + 1
        End If
    Next

    MsgBox "Total number of " & strName & " counts are :" & CStr(intAdd)
    GetMS4AppInventory (strName)
End Sub


Sub GetMS4AppInventory(strName As String)

    Dim strAction
    Dim intAdd As Integer
    Dim RowIndex As Integer
    RowIndex = 0

    Sheets("Sheet1").Select

    'For Each cell In Range("G2:G700")
    With Worksheets("Sheet1").Range("G2:G700")
        Set strAction = .Find(strName, LookIn:=xlValues)

        'strAction = cell.Value
        If Not strAction Is Nothing Then
            Do
                If InStr(1, strAction, strName) <> 0 Then
                    Rows(strAction.Row).Select
                    Selection.Copy

                    Sheets("MS4Inventory").Select
                    Rows(RowIndex + 1).Select
                    Selection.Insert Shift:=xlDown
                    Rows(RowIndex + 2).Select
                    Application.CutCopyMode = False
                    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                    Cells(RowIndex + 3, 1).Select
                End If

                Set strAction = .FindNext(strAction)  //gets hanged here go to infinite loop
            Loop While Not strAction Is Nothing
        End If
    End With
End Sub

如果任何人都可以帮助我，那么手动进行库存分离将会很糟糕。

问候，

维杰

Answer 1

使用FindNext时，必须存储找到的第一个单元格的地址并进行比较。 在你的例子中，strAction永远不会是Nothing，因为FindNext将继续找到第一个拥有它的单元格。

我不确定你的白色和黄色行是如何影响到这一点的，但这里是查找单元格和复制行的基本结构。 也许您可以根据需要对其进行修改，或者澄清现有数据的样子。

Sub GetInterfaceCounts()

    Dim sName As String
    Dim rFound As Range
    Dim lCount As Long
    Dim sFirstAdd As String

    'Get the application name from the user
    sName = InputBox(Prompt:="Please enter the application name.", _
        Title:="Application Name", Default:="Application")

    'if the user doesn't press cancel
    If Len(sName) > 0 Then
        'Find the first instance of the application
        Set rFound = Sheet1.Columns(7).Find(sName, , xlValues, xlPart, , , False)

        'if something was found
        If Not rFound Is Nothing Then
            'Remember the first address where it was found
            sFirstAdd = rFound.Address

            Do
                lCount = lCount + 1
                'Copy the entirerow to the other sheet
                rFound.EntireRow.Copy _
                    rFound.Parent.Parent.Sheets("MS4Inventory").Cells(lCount, 1).EntireRow
                'Find the next instance
                Set rFound = Sheet1.Columns(7).FindNext(rFound)

            'if we've looped around to the first found, then get out
            Loop Until rFound.Address = sFirstAdd
        End If

        MsgBox "Total number of " & sName & " counts are :" & lCount
    End If

End Sub