none
Seleccionar datos en macro Excel RRS feed

  • Pregunta

  • Bueno les cuento espero puedan ayudarme,

    tengo una macro creada en Excel 2013 la cual en el evento Worksheet_SelectionChange al posicionarme en una celda de la columna "producto" se muestra el contenido de esta misma en otra celda.

    Bueno lo que necesito es que al posicionarme en una celda, por ejemplo en la celda del "producto 3" en la hoja1, busque todos los Productos de "productos 3" que estén en la hoja2 y que me los muestre en otra hoja incluyendo el valor y el margen.

    HOJA1

    producto Valor Margen
    producto 1 1200 2
    producto 2 1201 4
    producto 3 1202 6
    producto 4 1203 8
    producto 5 1204 10
    producto 6 1205 12
    producto 7 1206 14

    HOJA2

    producto Valor Margen
    producto 1 1200 2
    producto 1 1500 3
    producto 1 5622 5
    producto 2 1201 4
    producto 3 1202 6
    producto 3 2530 8
    producto 4 1203 8
    producto 5 1204 10
    producto 6 1205 12
    producto 7 1206 14

    así deberia quedar la Hoja3 al hacer click a la celda de "producto 3" en la hoja1

    producto Valor Margen
    producto 3 1202 6
    producto 3 2530 8

    Ojalá puedan ayudarme se los agradecería mucho!!

    Saludos!!

    Francisco Vera B.

    jueves, 18 de julio de 2013 17:11

Respuestas

  • Private Sub Worksheet_SelectionChange(ByVal Target As Range)
        On Error Resume Next
        Dim Ws1 As Worksheet    'Hoja1
        Dim Ws2 As Worksheet    'Hoja2
        Dim WsD As Worksheet    'Hoja3
        Dim i As Long           'Para recorrer las filas de la hoja 2
                                'como no sabemos cuantas filas hay elegimos
                                'Long por si acaso
        Dim j As Long           'Para recorrer las filas de la hoja 3
                                'como no sabemos cuantas filas hay elegimos
                                'Long por si acaso
        
        'Salimos si:
        '   La columna de la seleccion no es la primera
        '   La fila de la seleccion es la primera
        '   Se seleccionan mas de una celda
        '   Se selecciona una celda vacia
        If Target.Column <> 1 Or Target.Row = 1 Or Target.Count > 1 Or _
           Len(Target) = 0 Then Exit Sub
           
        On Error GoTo ErrHandler
           
        'Congelamos la pantalla para acelerar el propceso
        Application.ScreenUpdating = False
        
        Set Ws1 = Me
        Set Ws2 = ThisWorkbook.Worksheets("Hoja2")
        Set WsD = ThisWorkbook.Worksheets.Add
        i = 2
        j = 2
        
        'Encabezados de la hoja 3
        WsD.Cells(1, 1) = "Producto"
        WsD.Cells(1, 2) = "Valor"
        WsD.Cells(1, 3) = "Margen"
        'Buscamos en la Hoja2 hasta encontrarnos con una celda vacia
        Do Until Len(Ws2.Cells(i, 1)) = 0
            If Ws2.Cells(i, 1) = Target Then
                WsD.Cells(j, 1) = Ws2.Cells(i, 1)
                WsD.Cells(j, 2) = Ws2.Cells(i, 2)
                WsD.Cells(j, 3) = Ws2.Cells(i, 3)
                j = j + 1
            End If
            i = i + 1
        Loop
        
        WsD.Select
        Application.ScreenUpdating = True
        
        Exit Sub
    ErrHandler:
        
        Application.ScreenUpdating = True
        
        MsgBox "Ha habido un error a lo largo de la ejecución de la macro. " & _
            "Esta no ha podido ser ejecutada en su totalidad.", vbOKOnly + _
            vbCritical, "Atención"
    End Sub

    Más mascado imposible, jeje. Espero haberte podido ayudar.

    Un saludo.


    Working Into Binary (WIB) - http://workingintobinary.blogspot.com.es/

    • Propuesto como respuesta Albert Álvarez viernes, 19 de julio de 2013 10:31
    • Marcado como respuesta fverab viernes, 19 de julio de 2013 13:22
    viernes, 19 de julio de 2013 10:29

Todas las respuestas

  • Private Sub Worksheet_SelectionChange(ByVal Target As Range)
        On Error Resume Next
        Dim Ws1 As Worksheet    'Hoja1
        Dim Ws2 As Worksheet    'Hoja2
        Dim WsD As Worksheet    'Hoja3
        Dim i As Long           'Para recorrer las filas de la hoja 2
                                'como no sabemos cuantas filas hay elegimos
                                'Long por si acaso
        Dim j As Long           'Para recorrer las filas de la hoja 3
                                'como no sabemos cuantas filas hay elegimos
                                'Long por si acaso
        
        'Salimos si:
        '   La columna de la seleccion no es la primera
        '   La fila de la seleccion es la primera
        '   Se seleccionan mas de una celda
        '   Se selecciona una celda vacia
        If Target.Column <> 1 Or Target.Row = 1 Or Target.Count > 1 Or _
           Len(Target) = 0 Then Exit Sub
           
        On Error GoTo ErrHandler
           
        'Congelamos la pantalla para acelerar el propceso
        Application.ScreenUpdating = False
        
        Set Ws1 = Me
        Set Ws2 = ThisWorkbook.Worksheets("Hoja2")
        Set WsD = ThisWorkbook.Worksheets.Add
        i = 2
        j = 2
        
        'Encabezados de la hoja 3
        WsD.Cells(1, 1) = "Producto"
        WsD.Cells(1, 2) = "Valor"
        WsD.Cells(1, 3) = "Margen"
        'Buscamos en la Hoja2 hasta encontrarnos con una celda vacia
        Do Until Len(Ws2.Cells(i, 1)) = 0
            If Ws2.Cells(i, 1) = Target Then
                WsD.Cells(j, 1) = Ws2.Cells(i, 1)
                WsD.Cells(j, 2) = Ws2.Cells(i, 2)
                WsD.Cells(j, 3) = Ws2.Cells(i, 3)
                j = j + 1
            End If
            i = i + 1
        Loop
        
        WsD.Select
        Application.ScreenUpdating = True
        
        Exit Sub
    ErrHandler:
        
        Application.ScreenUpdating = True
        
        MsgBox "Ha habido un error a lo largo de la ejecución de la macro. " & _
            "Esta no ha podido ser ejecutada en su totalidad.", vbOKOnly + _
            vbCritical, "Atención"
    End Sub

    Más mascado imposible, jeje. Espero haberte podido ayudar.

    Un saludo.


    Working Into Binary (WIB) - http://workingintobinary.blogspot.com.es/

    • Propuesto como respuesta Albert Álvarez viernes, 19 de julio de 2013 10:31
    • Marcado como respuesta fverab viernes, 19 de julio de 2013 13:22
    viernes, 19 de julio de 2013 10:29
  • Albert muchas gracias funcionó perfecto!

    ahora haré algunas modificaciones para adecuarlo a mi libro

    GRACIAS!

    viernes, 19 de julio de 2013 13:24