Consultar un código repetido y desglosar de manera horizontal los números de filas en los que se encuentra dicho código

Necesito ayuda con una macro en Excel que haga lo siguiente, de antemano agradezco su ingenio y ayuda!
Tengo un inventario donde hay una lista de códigos y cada uno posee un numero de ubicación en bodega, necesito que los códigos repetidos me muestren de manera horizontal el numero de fila donde se ubica(una fila por celda horizontalmente), haciendo que los repetidos solo se muestren como valores únicos, Así es como tengo los datos:

Código Cajas

GS4556 14

GS4556     2

GS4552     8

GS4556    14

HB5847     3

SP55845    1

SP55845    2

Asi es como necesito se desglose por favor.

Codigo    F1     F2     F3     F4     F5    F6     F7

GS4556   14      2      14

GS4552    8

HB5847     3

SP55845    1      2

1

1 respuesta

Respuesta
1

H o l a:

Te anexo una macro, deberás tener 2 hojas "Hoja1" y "Hoja2".

Sub Desglosar()
'Por.Dante Amor
    Set h1 = Sheets("Hoja1")
    Set h2 = Sheets("Hoja2")
    h2.Cells.ClearContents
    h2.[A1] = h1.[A1]
    h2.[B1] = "F1"
    n = 2
    For i = 2 To h1.Range("A" & Rows.Count).End(xlUp).Row
        Set b = h2.Columns("A").Find(h1.Cells(i, "A"), lookat:=xlWhole)
        If Not b Is Nothing Then
            uc = h2.Cells(b.Row, Columns.Count).End(xlToLeft).Column + 1
            If h2.Cells(1, uc) = "" Then h2.Cells(1, uc) = "F" & n
            h2.Cells(b.Row, uc) = h1.Cells(i, "B")
            n = n + 1
        Else
            uf = h2.Range("A" & Rows.Count).End(xlUp).Row + 1
            h2.Cells(uf, "A") = h1.Cells(i, "A")
            h2.Cells(uf, "B") = h1.Cells(i, "B")
        End If
    Next
    MsgBox "Fin"
End Sub

Pon tu información en la "Hoja1", en las columnas A y B, empezando en la fila 1:


El resultado quedará en la "Hoja2" de esta forma:


Sigue las Instrucciones para un botón y ejecutar la macro

  1. Abre tu libro de Excel
  2. Para abrir Vba-macros y poder pegar la macro, Presiona Alt + F11
  3. En el menú elige Insertar / Módulo
  4. En el panel del lado derecho copia la macro
  5. Ahora para crear un botón, puedes hacer lo siguiente:
  6. Inserta una imagen en tu libro, elige del menú Insertar / Imagen / Autoformas
  7. Elige una imagen y con el Mouse, dentro de tu hoja, presiona click y arrastra el Mouse para hacer grande la imagen.
  8. Una vez que insertaste la imagen en tu hoja, dale click derecho dentro de la imagen y selecciona: Tamaño y Propiedades. En la ventana que se abre selecciona la pestaña: Propiedades. Desmarca la opción “Imprimir Objeto”. Presiona “Cerrar”
  9. Vuelve a presionar click derecho dentro de la imagen y ahora selecciona: Asignar macro. Selecciona: Desglosar
  10. Aceptar.
  11. Para ejecutarla dale click a la imagen.

' : )
'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias
' : )

Primeramente Muchas gracias esta perfecta tu solución y es totalmente acorde a lo que necesitaba, pero acabo de notar algo que no había contemplado y es que tengo códigos donde el número de filas(escribí cajas fue error mio) se repite muchas veces, quería ver si ¿hay modo de que si se repite el número de fila solo se presente una vez y posteriormente la contigua sin que se repitan?

Mira esto es lo que me sale e insisto es tal como lo redacte solo que no pensé en este detalle:

Lo que quisiera, claro si es posible es saber como hacer para que solo aparezcan como valores únicos tambien las filas por dar un ejemplo seria :

Código      F1  F2   F3

GS50303   8    17

GS50304   8     17

En lugar de que se repitan como lo hacen en la imagen, claro si le es posible por favor.

De antemano Agradezco enormemente tu ayuda! 

Te anexo la actualización

Sub Desglosar()
'Por.Dante Amor
    Set h1 = Sheets("Hoja1")
    Set h2 = Sheets("Hoja2")
    h2.Cells.ClearContents
    h2.[A1] = h1.[A1]
    h2.[B1] = "F1"
    n = 2
    For i = 2 To h1.Range("A" & Rows.Count).End(xlUp).Row
        Set b = h2.Columns("A").Find(h1.Cells(i, "A"), lookat:=xlWhole)
        If Not b Is Nothing Then
            fila = b.Row
            uc = h2.Cells(b.Row, Columns.Count).End(xlToLeft).Column + 1
            Set b = h2.Range(h2.Cells(fila, 2), h2.Cells(fila, uc)).Find(h1.Cells(i, "B"), lookat:=xlWhole)
            If b Is Nothing Then
                If h2.Cells(1, uc) = "" Then
                    h2.Cells(1, uc) = "F" & n
                    n = n + 1
                End If
                h2.Cells(fila, uc) = h1.Cells(i, "B")
            End If
        Else
            uf = h2.Range("A" & Rows.Count).End(xlUp).Row + 1
            h2.Cells(uf, "A") = h1.Cells(i, "A")
            h2.Cells(uf, "B") = h1.Cells(i, "B")
        End If
    Next
    MsgBox "Fin"
End Sub

¡Gracias! De verdad muchas gracias, eres muy bueno en esto, ya podré avanzar más rápido en esta actividad, ten un gran día y mucho éxito!

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas