Buen día

Por favor su ayuda..

En archivo adjunto encontraran unos datos que debo transformar según las siguientes condiciones: 

-En cada una de las celdas de la columna A hay una serie de datos de 4 dígitos separados por punto y coma(;). La idea es separar cada uno de esos datos y pegarle la misma información que hay en el resto de la fila, como se hizo de ejemplo en la pestaña "Ejemplo", donde se cogieron los 17 datos que hay agrupados en la celda A2 de pestaña "datos a trabajar",  y se utilizo texto en columnas para separarlos y luego se transpusieron en la columna A y  simplemente se relleno con los mismos datos de la fila 2. Y hacer esto mismo con todas las demas celdas de la columna A. Se requiere automatizar esto ya que son cientos de filas con muchos datos en la columna A que expandir y hacerlo manualmente seria muy complejo y quizás con margen de error. 

Espero haya hecho entender lo que necesito, cualquier pregunta estaré pendiente 

mil gracias.

 

Para Automatizar.xlsx

Abre el adjunto y pulsa sobre la flecha azul.

La macro es algo lenta, pero no dispongo de más tiempo para pensar en una solución más eficiente.

En la barra de estado de Excel, a la izquierda, irá apareciendo el avance del proceso.

Para Automatizar.xlsm

Espero sea lo que necesites

la invocas con el atajo  :  Ctrl+Mayús+Q

 

Sub SeparaDatos()
'
' SeparaDatos Macro
' Creado por: .::Andres Guerrero Avellan::. Guayaquil - Ecuador  
'Selecciona los datos de Celda A ,los separa los "traspone" y luego rellena con los datos de B:I
'
' Acceso directo: Ctrl+Mayús+Q
'

'Selecciona la pagina y llega cual es el ultimo registro a  trabajar.
Sheets("Datos_a_trabajar").Select
Dim Ultima As Long
Dim Codigos() As String
    Ultima = (ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row) ' Veo cual es el ultima celda
    I = 2 ' por que inicio desde A2 podria ser A3 o la que interese.
    k = 2 ' por que el destino empezara en 2
    Application.ScreenUpdating = False
         Sheets("Resultado").Range("A2:I20000").Clear
    For I = 2 To Ultima ' mientras el ciclo no llegue al ultimo registro.

        Codigos = Split(Sheets("Datos_a_trabajar").Range("A" & I).Value, ";")
        
        For j = 0 To UBound(Codigos)
            Sheets("Resultado").Select
            
            Range("A" & k).Select
            Range("A" & k).Value = Codigos(j)
            Range("B" & k).Value = Sheets("Datos_a_trabajar").Range("B" & I).Value
            Range("C" & k).Value = Sheets("Datos_a_trabajar").Range("C" & I).Value
            Range("D" & k).Value = Sheets("Datos_a_trabajar").Range("D" & I).Value
            Range("E" & k).Value = Sheets("Datos_a_trabajar").Range("E" & I).Value
            Range("F" & k).Value = Sheets("Datos_a_trabajar").Range("F" & I).Value
            Range("G" & k).Value = Sheets("Datos_a_trabajar").Range("G" & I).Value
            Range("H" & k).Value = Sheets("Datos_a_trabajar").Range("H" & I).Value
            Range("I" & k).Value = Sheets("Datos_a_trabajar").Range("i" & I).Value
            k = k + 1
        Next j
        
    Next I
Application.ScreenUpdating = True
 Range("A2").Select
 MsgBox "Proceso Terminado" & vbCr & Ultima - 1 & " Registros procesados" & vbCr & k - 1 & " Registros Resultados", vbInformation, "AG-Trasponer"
 
End Sub

 

Para Automatizar.xlsm

Cita

Hace 45 minutos , Antoni dijo:

Abre el adjunto y pulsa sobre la flecha azul.

La macro es algo lenta, pero no dispongo de más tiempo para pensar en una solución más eficiente.

En la barra de estado de Excel, a la izquierda, irá apareciendo el avance del proceso.

Para Automatizar.xlsm 18 kB · 1 download

 

 Maestro!! vaya que 8 lineas dejar reverendo codigo me que quedado anonadado... nada que hacer que lo tuyo es esto...

respecto a la lentitud puede ser por utilizar el clipboard y no asignacion lo cual ha ayudado a optimizar el codigo .. 

He propuesto un procedimiento si bien algo mas extenso ayuda a este tema .. espero lo chequees y me brindes tus comentarios quizas y entre la rapidez y la optimizacion de codigo algo mejor sacamos

SALudos

Andres 

Hace 2 horas, Antoni dijo:

Abre el adjunto y pulsa sobre la flecha azul.

La macro es algo lenta, pero no dispongo de más tiempo para pensar en una solución más eficiente.

En la barra de estado de Excel, a la izquierda, irá apareciendo el avance del proceso.

Para Automatizar.xlsm 18 kB · 3 downloads

 

Hace 1 hora, silver_axe007 dijo:

 Maestro!! vaya que 8 lineas dejar reverendo codigo me que quedado anonadado... nada que hacer que lo tuyo es esto...

respecto a la lentitud puede ser por utilizar el clipboard y no asignacion lo cual ha ayudado a optimizar el codigo .. 

He propuesto un procedimiento si bien algo mas extenso ayuda a este tema .. espero lo chequees y me brindes tus comentarios quizas y entre la rapidez y la optimizacion de codigo algo mejor sacamos

SALudos

Andres 

Muchas Gracias a ambos. Si tengo alguna inquietud o inconveniente extra les cuento

Saludos,

Saludos @cristian9209, te dejo otra opcion, muy parecida a la del maestro @Antoni

Sub Explotar2()
    Dim mDatos() As Variant
    Dim mTempo() As Variant
    Dim j As Long
    Dim k As Long
    
    Application.ScreenUpdating = False
    Hoja2.Select
    Hoja2.Cells.Clear
    Hoja1.Rows(1).Copy Hoja2.Rows(1)
    ReDim mDatos(100000, 9)
    For X = 2 To Hoja1.Range("A" & Rows.Count).End(xlUp).Row
        Application.StatusBar = "Procesando fila " & X & "/" & Hoja1.Range("A" & Rows.Count).End(xlUp).Row
        
        mTempo = Hoja1.Range("A" & X & ":I" & X)
        plant = Split(Hoja1.Range("A" & X), ";")
        For p = 0 To UBound(plant)
            For k = 1 To UBound(mTempo, 2)
                mDatos(j, k - 1) = mTempo(1, k)
            Next k
            mDatos(j, 0) = plant(p)
            j = j + 1
        Next
        
    Next
    
    Hoja2.Range("A2").Resize(j, 9) = mDatos
    Application.StatusBar = False
End Sub

 

Hola!

Adjunto mi versión con VBA, ademas otro método utilizando Power Query [mi preferido]

 

Saludos a todos

Transformar datos VBA y Power Query_GP.zip