Macro para trasponer Datos por campo clave

[Gsus]

Buenas, tengo un fichero con un montón de registros (yo os paso un ejemplo). Donde los datos vienen estructurados por orden de la siguiente manera: A, A1, A2 / a veces solo A y A1; y otras solo la A

Por ejemplo:

Clave	Nivel	Cantidad
1	A	50
1	A1	25
1	A2	25

Y lo que quiero es esto:

Clave	Nivel	Cantidad	A1	A2
1	A	50	25	25
1	A1	25
1	A2	25

De modo que la A es la raíz y ese, A1 y A2 son ramificaciones. Necesito añadir al lado de esa A, el dato de la cantidad de A1 y A2

No se me ocurre cómo hacerlo.

Os paso ejemplo por si me podéis echar un cable. 

Muchas gracias!

Ejemplo_FORO.7z

[JSDJSD]

Prueba y comenta

[JSDJSD]

Private Sub CommandButton1_Click(): Application.ScreenUpdating = False

With Hoja1
    .Range("D2", "E" & .Range("A" & .Rows.Count).End(xlUp).Row).ClearContents
    ' Aplicar filtro avanzado en columna A y copiar resultados a columna R
    .Range("A:A").AdvancedFilter 2, , .Range("R1"), 1

    ' Inicializar una variable para almacenar la clave
    Dim clave As Variant

    ' Recorrer las filas desde la segunda fila hasta la última fila en columna R
    For x = 2 To .Range("R" & .Rows.Count).End(xlUp).Row
        clave = .Cells(x, 18) ' Obtener el valor de la celda en la columna R

        ' Recorrer la columna A para buscar coincidencias con la clave
        For Each buscado In .Range("A2:A" & .Range("A" & .Rows.Count).End(xlUp).Row)
            If buscado = clave And .Cells(buscado.Row, 2) = "A" Then
                posicion = buscado.Row ' Almacenar la posición de la coincidencia
            End If
            ' Verificar las condiciones y realizar las acciones necesarias
            If buscado = clave And .Cells(buscado.Row, 2) = "A1" Then
                .Cells(posicion, 4) = .Cells(buscado.Row, 3) ' Copiar valor a columna D
            ElseIf buscado = clave And .Cells(buscado.Row, 2) = "A2" Then
                .Cells(posicion, 5) = .Cells(buscado.Row, 3) ' Copiar valor a columna E
                Exit For ' Salir del bucle una vez que se encuentre una coincidencia A2
            End If

        Next
    Next x

    ' Eliminar la columna 18 (columna R)
    .Columns(18).Delete
End With
End Sub

 

Ejemplo_FORO.xlsm

[Gsus]

hace 10 horas, JSDJSD dijo:

Private Sub CommandButton1_Click(): Application.ScreenUpdating = False

With Hoja1
    .Range("D2", "E" & .Range("A" & .Rows.Count).End(xlUp).Row).ClearContents
    ' Aplicar filtro avanzado en columna A y copiar resultados a columna R
    .Range("A:A").AdvancedFilter 2, , .Range("R1"), 1

    ' Inicializar una variable para almacenar la clave
    Dim clave As Variant

    ' Recorrer las filas desde la segunda fila hasta la última fila en columna R
    For x = 2 To .Range("R" & .Rows.Count).End(xlUp).Row
        clave = .Cells(x, 18) ' Obtener el valor de la celda en la columna R

        ' Recorrer la columna A para buscar coincidencias con la clave
        For Each buscado In .Range("A2:A" & .Range("A" & .Rows.Count).End(xlUp).Row)
            If buscado = clave And .Cells(buscado.Row, 2) = "A" Then
                posicion = buscado.Row ' Almacenar la posición de la coincidencia
            End If
            ' Verificar las condiciones y realizar las acciones necesarias
            If buscado = clave And .Cells(buscado.Row, 2) = "A1" Then
                .Cells(posicion, 4) = .Cells(buscado.Row, 3) ' Copiar valor a columna D
            ElseIf buscado = clave And .Cells(buscado.Row, 2) = "A2" Then
                .Cells(posicion, 5) = .Cells(buscado.Row, 3) ' Copiar valor a columna E
                Exit For ' Salir del bucle una vez que se encuentre una coincidencia A2
            End If

        Next
    Next x

    ' Eliminar la columna 18 (columna R)
    .Columns(18).Delete
End With
End Sub

 

Ejemplo_FORO.xlsm 28.66 kB · 1 descarga

Muchísimas, gracias! Funciona a la perfección!