Copiar filas n veces de acuerdo a una celda

Agradecería me ayudaran con una macro para el sig ejercicio
tengo un rango de celdas A1:FX (donde POR es un numero cambiante) hasta que la fila este vacía por ejemplo.
Lo que quiero es crear una macro que me copie en un documento nuevo
todas las filas del rango pero cada fila POR veces determinado por el valor establecido en la celda EX (X rango dado arriba)
Ej:
cod articulo ... Cant
123 camisa ... 5
456 pantalón ... 3
789 blusa ... 4
La idea es que copie en un nuevo archivo
5 filas con "123 camisa... Etc
3 filas con "456 pantalón ... Etc
Y así sucesivamente

1 respuesta

Respuesta
4
Interesante situación la tuya. Te dejo el código. Me avisas si anda
PD: Debes lanzarla desde la primera celda que quieres que se copie
**************************
Sub RepetirRegistro()
'Creada por FSerrano en 110525
'Para dfcalderon en TodoExpertos.com
'Desactiva la actualización automatica de pantalla, para hacer el proceso más rapido
Application.ScreenUpdating = False
'Captura la ultima columna del rango
ultimacolumna = Selection.End(xlToRight).Column
'Captura el nombre del libro actual
librobase = ActiveWorkbook.Name
'Crea un nuevo libro y captura su nombre
Workbooks.Add
libronuevo = ActiveWorkbook.Name
'Vuelve al libro original
Workbooks(librobase).Activate
'Repite el bucle mientras la celda contenga valores
While ActiveCell <> ""
    'Copia toda la fila a excepción de la ultima columna
    Range(ActiveCell.Address, Cells(ActiveCell.Row, ultimacolumna - 1)).Copy
    'Captura el numero de veces que debe repetirse el registro actual
    bucle = Cells(ActiveCell.Row, ultimacolumna).Value
    'Va al libro nuevo y pega los datos copiados
    Workbooks(libronuevo).Activate
    For i = 1 To bucle
        ActiveCell.PasteSpecial xlPasteAll
        ActiveCell.Offset(1, 0).Activate
    Next
    'Vuelve al libro base
    Workbooks(librobase).Activate
    ActiveCell.Offset(1, 0).Activate
Wend
'Activa el libro nuevo
Workbooks(libronuevo).Activate
'Activa la actualización automatica de la pantalla
Application.ScreenUpdating = True
End Sub
******************************

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas