Macro que al escribir en una celda ponga la o las respuestas debajo de esta

Estoy haciendo una base de datos el cual tengo códigos que estos lo forman otros componentes pero los tengo separados y quiero que cada vez que escriba cualquier código la macro me ponga automáticamente los componentes por debajo de este, solo que son mas de 30 códigos y varios componentes no importa en que columna vaya pues pienso ocuparla para varios libros de Excel.

Espero su ayuda.

2 respuestas

Respuesta
1

Para hacer la macro, necesitas tener en otra hoja la relación de código y componente.

Por ejemplo, poner la relación en la hoja2

Si ya tienes la relación, dime cómo se llama la hoja y en qué columnas está el código y el componente.

Gracias por su pronta ayuda, la hoja donde tengo la relación se llama BOM, el código está en la columna A y el componente en la columna B.

Pero tienes los código de forma continua, ¿tal cómo te puse en mi ejemplo?

Así es, ya los puse como en su ejemplo

Te anexo la macro, para que la pongas en los eventos de tu hoja donde vas a capturar un código y quieres que se traigan los componentes.

Private Sub Worksheet_Change(ByVal Target As Range)
'Por.Dante Amor
    If Target.Count > 1 Then Exit Sub
    If Target.Value = "" Then Exit Sub
    Application.ScreenUpdating = False
    f = Target.Row
    Set r = Sheets("BOM").Columns("A")
    Set b = r.Find(Target.Value, lookat:=xlWhole)
    If Not b Is Nothing Then
        Application.EnableEvents = False
        ncell = b.Address
        Do
            f = f + 1
            Rows(f).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
            Cells(f, Target.Column) = b.Offset(, 1)
            Set b = r.FindNext(b)
        Loop While Not b Is Nothing And b.Address <> ncell
        Application.EnableEvents = True
    End If
    Application.ScreenUpdating = True
End Sub

Sigue las Instrucciones para poner la macro en los eventos de worksheet

  1. Abre tu libro de excel
  2. Para abrir Vba-macros y poder pegar la macro, Presiona Alt + F11
  3. Del lado izquierdo dice: VBAProject, abajo dale doble click a worksheet(tu hoja)
  4. Del lado derecho copia la macro

Saludos. Dante Amor

Recuerda valorar la respuesta.

Una última pregunta experto, no habrá forma de que la macro no inserte nuevas filas al ejecutarse (pegar los componentes), Lo que pasa es que tengo fórmulas a los lados y estas me las recorre

Te anexo la macro actualizada.

Private Sub Worksheet_Change(ByVal Target As Range)
'Por.Dante Amor
    If Target.Count > 1 Then Exit Sub
    If Target.Value = "" Then Exit Sub
    Application.ScreenUpdating = False
    f = Target.Row
    Set r = Sheets("BOM").Columns("A")
    Set b = r.Find(Target.Value, lookat:=xlWhole)
    If Not b Is Nothing Then
        Application.EnableEvents = False
        ncell = b.Address
        Do
            f = f + 1
            'Rows(f).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
            Cells(f, Target.Column) = b.Offset(, 1)
            Set b = r.FindNext(b)
        Loop While Not b Is Nothing And b.Address <> ncell
        Application.EnableEvents = True
    End If
    Application.ScreenUpdating = True
End Sub

Saludos.Dante Amor

Recuerda valorar la respuesta.

Respuesta
1

La siguiente rutina se ejecuta cada vez que introduzcas un dato en col E (esto se puede ajustar a otra col y a otra hoja)

Debes entrar al Editor, seleccionar con doble clic la hoja donde vayas a ingresar los datos y copiar esto. Hay varias lìneas que dicen AJUSTAR para que lo adaptes a tus necesidades, sino me consultas nuevamente con todas tus referencias.

Private Sub Worksheet_Change(ByVal Target As Range)
'x Elsamatilde
'solo controla ingresos en col E - AJUSTAR
If Target.Column <> 5 Then Exit Sub
'si se modfica un rango o se borran celdas no ejecuta
If Target.Count > 1 Then Exit Sub
If Target.Value = "" Then Exit Sub
'busca el dato en col B:C de la hoja 3 - AJUSTAR
Set busco = Sheets("Hoja3").Range("B:B").Find(Target.Value, LookIn:=xlValues, lookat:=xlWhole)
'si lo encontró pasa datos debajo de la celda target o activa
If Not busco Is Nothing Then
'inhabilita que se ejecute nuevamente el 'cambio' en celdas
Application.EnableEvents = False
'se pasa en fila de abajo el dato de la col siguiente - AJUSTAR
X = Target.Row + 1
'guardo la fila del dato encontrado
filx = busco.Row
Range("E" & X) = Range("C" & filx).Value
filx = filx + 1
'fila de destino
While Range("B" & filx) = "" And Range("C" & filx) <> ""
X = X + 1
Range("E" & X) = Range("C" & filx).Value
filx = filx + 1
Wend
'inhabilita que se ejecute nuevamente el 'cambio' en celdas
Application.EnableEvents = True
End If
End Sub

PD) Utilicé  variables para que puedas ajustar a criterio.

Como la macro inhabilita la ejecución de las macros mientras vuelca los componentes, sería recomendable que coloques en algún módulo lo siguiente, por si en algún caso de error se interrumpa la anterior y así podrás volver a habilitarlas.

Sub activaMacros()

Application.EnableEvents = True
End Sub

Sdos y no olvides valorar esta respuesta.

Creo qué mi respuesta fue anterior y también totalmente correcta... podrías valorar también mi tiempo y dedicación a tu consulta?

Sdos!

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas