Excel VBA проблема с поиском

Question

Я новичок в VBA, хотя и пытался приложить усилия, но безуспешно.

Постановка задачи:

У меня есть лист со строкой источника (цвет белый) и строкой назначения (цвет желтый), для каждого источника есть соответствующая строка назначения в следующей строке. Мне нужно искать имя приложения, которое пользователь вводит в начале и которое будет искать по всему листу (более 10000 строк) в столбце 6, и оно должно извлекать исходную строку также, если она найдена в строке назначения и в строке назначения, также если она найдена в строке источника в листе 2.

А также в одной ячейке может быть много названий приложений, поэтому она должна обрезать все другие имена приложений из этой ячейки и оставлять только имя искомого приложения.

Вот частичный код, который я пробовал:

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