Excel VBA lookup issue

Question

I'm new to excel VBA though I tried putting efforts but of no luck.

Problem Statement:

I have a sheet with Source (color white) row and Destination (color Yellow) row, for each source there is a corresponding destination row in next line. I have to look for an application name which user input at the beginning and will search throughout the sheet (more than 10000 rows) in column 6 and it must extract the source row also if found in destination and destination row also if found in source row in sheet2.

And also one cell may have many application name within it so it should trim all other app names from that cell and leave only the searched app name.

Here is the partial code i tried :

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

If anybody could help me it will be great else manually doing seggregation of inventory will suck me.

Regards,

Vijay

Answer 1

When you use FindNext, you have to store the first found cell's address and compare it. strAction, in your example, will never be Nothing because FindNext will keep finding the first cell that had it.

I'm not sure how your white and yellow rows factor into this, but here's a basic structure for finding cells and copy their rows. Maybe you can modify it to your needs or clarify what your existing data looks like.

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