Problema de búsqueda de Excel VBA

Soy nuevo en sobresalir en VBA, aunque intenté esforzarme pero no tuve suerte.

Planteamiento del problema:

Tengo una hoja con la fila Fuente (color blanco) y la fila Destino (color amarillo), para cada fuente hay una fila de destino correspondiente en la siguiente línea. Tengo que buscar un nombre de aplicación que el usuario ingresa al principio y buscaré en toda la hoja (más de 10000 filas) en la columna 6 y debe extraer la fila de origen también si se encuentra en la fila de destino y también si se encuentra en la fila de origen en la hoja 2.

Y también una celda puede tener muchos nombres de aplicaciones dentro de ella, por lo que debe recortar todos los demás nombres de aplicaciones de esa celda y dejar solo el nombre de la aplicación buscada.

Aquí está el código parcial que probé:

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

Si alguien pudiera ayudarme, sería genial, de lo contrario, hacer manualmente la segregación del inventario me chuparía.

Saludos,

Vijay

preguntado el 16 de mayo de 11 a las 17:05

¿Cuál es la estructura de su hoja de entrada? -

Range.Offset y Range.Resize son tus amigos en lugar de hacer referencia a varias celdas con G2:G700. Obtienen los valores en una matriz de variantes con Range.Value y busque en la matriz en lugar de en las celdas una por una. -

1 Respuestas

Cuando usa FindNext, debe almacenar la dirección de la primera celda encontrada y compararla. strAction, en su ejemplo, nunca será Nothing porque FindNext seguirá encontrando la primera celda que lo tenía.

No estoy seguro de cómo influyen sus filas blancas y amarillas en esto, pero aquí hay una estructura básica para encontrar celdas y copiar sus filas. Tal vez pueda modificarlo según sus necesidades o aclarar cómo se ven sus datos existentes.

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

contestado el 17 de mayo de 11 a las 00:05

Hola Dick, Realmente quiero agradecerle que funcionó, pero créanme, mi problema es diferente, era un lugar donde mis esfuerzos se estancaron. Primero quiero saber por qué la línea rFound.EntireRow.Copy _ rFound.Parent.Parent.Sheets ("MS4Inventory"). Cells (lCount, 1) .EntireRow no funciona cuando las hago en una línea da un error de objeto. ¿Cómo puedo obtener las columnas en función del cálculo de que si se encuentra en una fila par, entonces requiere la siguiente fila que está en una posición impar, como si se encontrara en la fila 2, necesito la fila 3 o la encontré en la fila 5, necesito la fila 4 también en la siguiente hoja que son en realidad pares de origen y destino. - Vijay Baswal

No es la respuesta que estás buscando? Examinar otras preguntas etiquetadas or haz tu propia pregunta.