Hola, estoy intentando crear una macro que busque las filas con contenido en una hoja y que haga varias copias de este contenido en otra hoja, numerando el numero de copia. Hasta ahora he conseguido que me encuentre los valores y que copie y pegue pero no que me haga la cantidad de copias y las numere, adjunto codigo por si alguien me puede ayudar y también imagen de datos y resultado final que me gustaría obtener.

Sub Copiar_Filas()

'inicializo la variable j
j = 2
UltimaFila = Cells(Rows.Count, 2).End(xlUp).Row
Dim xCount As Integer
LableNumber:
xCount = Application.InputBox("Copias de Kits", "Total de copias", , , , , , 1)
If xCount < 1 Then
MsgBox "Cantidad de copias insuficiente ,intentar de nuevo", vbInformation, "Zfoam"
GoTo LableNumber
End If
    'comienzo el bucle
    For I = 2 To UltimaFila
        
        'activo la hoja donde están mis datos
        Sheets("Datos").Activate
            
            'compruebo que el valor de la fecha es mayor que 30
            If Cells(I, "B").Value <> 0 Then
                'copio la fila entera
                Range(Cells(I, "A"), Cells(I, "E")).Copy
                'selecciono la hoja donde quiero pegar y después la celda
                Sheets("Filtro").Activate
                    Cells(j, "A").Select
                'pego la fila que hemos copiado
                Rows(I).Resize(xCount).Insert
                'aumento la variable j para que vaya a la siguiente fila de la hoja filtros
                'cuando encuentre una nueva fila que cumple con la condición de edad
                j = j + 1
            End If
    Next

End Sub
 

Sube tu archivo, con ejemplos,

y vemos que se puede hacer

 

Saludos,

Diego.

Lo primero, muchas gracias por tu respuesta, me estoy volviendo loco de buscar ideas.

Sigo intentando modificar con lo que encuentro por ahí pero no lo consigo, adjunto fichero con 3 hojas, la primera tiene el contenido que he usado como muestra en la ubicación que estaría en el fichero de trabajo, a partir de la fila 7 puede ser un fichero con mas o menos contenido, yo para el ejemplo he usado solo 3 filas para no liarla, la única columna que me indica si hay que copiar es la que se llama código plano.

La segunda lo que me aparece a mi al ejecutar la macro "copiar filas" donde el contenido se coloca a partir de la fila 7 igual que en  la hoja datos y la tercera hoja lo que realmente me gustaría que saliera donde la columna I seria el numero de copia de la cantidad solicitada. Si pido 4 copias,  el primer bloque tendría el mismo valor que tenga la fila de  la que copia, el segundo un ese valor+1 (En este caso 2), el tercero ese valor+2........ Quiero decir que si el fichero empezara con un 3 por ejemplo, el primer bloque de copia seria un 3 el segundo un 4......

Vaya jaleo me he montado en la cabeza y no se si me he explicado correctamente.

Test duplicar columnas.xlsm

Lo reviso , , en un rato te paso una solución

Eres una máquina, muchas gracias.

SI HOY NADIE TE DA SOLUCIÓN MAÑANA TE MANDO EL CÓDIGO ESTIMADO, ANDO MEDIO OCUPADON,

SALUDOS

Aquí tienes una posible solución

El archivo 

Test duplicar columnas.xlsm

La verdad que un trabajo casi excelente, solo ha faltado, que en caso de empezar con un kit que no sea el 1, por ejemplo el 2, al pedir 3 copias, empiece por el 2 después el 3 y después el 4, voy a ver si lo consigo modificar o si te me puedes echar esta ultima mano genial, pero hasta aquí un trabajo y una ayuda excelente.

Cambia el código por este

Sub copiar(): Application.ScreenUpdating = False

    Hoja3.Range("A1", "A" & Hoja3.Range("B" & Rows.Count).End(xlUp).Row).EntireRow.Delete
    
    With Hoja1
        ufh = .Range("B" & Rows.Count).End(xlUp).Row
        arranque = .Range("I7")
        .Rows(6).Copy Hoja3.Range("A6")
        For cont = arranque To arranque + UserForm1.TextBox1.Value
            ufh1 = Hoja3.Range("B" & Rows.Count).End(xlUp).Row + 1
            .Range("A7", "I" & ufh).Copy Destination:=Hoja3.Range("A" & ufh1)
            For cont1 = 1 To 3
                Hoja3.Cells(Hoja3.Range("I" & Rows.Count).End(xlUp).Row - cont1 + 1, 9) = cont
            Next cont1
        Next cont
    End With
     UserForm1.ListBox1.RowSource = "'" & Hoja3.Name & "'!A6:I" & Hoja3.Range("B" & Rows.Count).End(xlUp).Row

End Sub

 

Finalmente lo he acoplado a mi fichero y me funciona excepto un pequeño detalle, como podría limitar la copia para que no poie nada de la columna I en adelante?

Asi me ha quedado en mi fichero:

Sub copiar(): Application.ScreenUpdating = False

    Hoja6.Range("A7", "A" & Hoja6.Range("C" & Rows.Count).End(xlUp).Row).EntireRow.Delete
    
    With Hoja7
        ufh = .Range("C" & Rows.Count).End(xlUp).Row
        arranque = .Range("I7")
        .Rows(6).Copy Hoja6.Range("A6")
        For cont = arranque To arranque + UserForm2.TextBox1.Value
            ufh1 = Hoja6.Range("C" & Rows.Count).End(xlUp).Row + 1
            .Range("A7", "I" & ufh).Copy Destination:=Hoja6.Range("A" & ufh1)
            For cont1 = 1 To 3
                Hoja6.Cells(Hoja6.Range("I" & Rows.Count).End(xlUp).Row - cont1 + 1, 9) = cont
            Next cont1
        Next cont
    End With
     UserForm2.ListBox1.RowSource = "'" & Hoja6.Name & "'!A6:I" & Hoja6.Range("C" & Rows.Count).End(xlUp).Row

End Sub

Tambien limitaria el borrado inicial para que no borre las filas enteras sino solo hasta la Columna I

Perdon que me he equivocado en el mensaje, lo que queria era limitar la copia en K aunque I sea el numero de copia. Estoy retocando el codigo poco a poco y me voy dando cuenta, asi es como lo tengo ahora:

Sub copiar(): Application.ScreenUpdating = False

    Hoja6.Range("A7", "A" & Hoja6.Range("C" & Rows.Count).End(xlUp).Row).EntireRow.Delete
    
    With Hoja7
        ufh = .Range("C" & Rows.Count).End(xlUp).Row
        arranque = .Range("I7")
        .Rows(6).Copy Hoja6.Range("A6")
        For cont = arranque To arranque + Hoja7.Range("A3")
            ufh1 = Hoja6.Range("C" & Rows.Count).End(xlUp).Row + 1
            .Range("A7", "I" & ufh).Copy Destination:=Hoja6.Range("A" & ufh1)
            For cont1 = 1 To 3
                Hoja6.Cells(Hoja6.Range("I" & Rows.Count).End(xlUp).Row - cont1 + 1, 9) = cont
            Next cont1
        Next cont
    End With
Hoja6.Select
End Sub

Lo he conseguido, solo me falta una cosa, al hacerse las copias, las celdas que contienen el resultado de una formula, se copia la formula y provoca un jaleo, como podría cambiarlo para que la copia fuera solo de los valores?

Aquí esta como tengo el código ahora, muchísimas gracias por vuestra ayuda y perdonar el lio.

Sub copiar(): Application.ScreenUpdating = False

    Hoja6.Range("A7", "A" & Hoja6.Range("C" & Rows.Count).End(xlUp).Row).EntireRow.Delete
    
    With Hoja7
        ufh = .Range("C" & Rows.Count).End(xlUp).Row
        arranque = .Range("I7")
        .Rows(6).Copy Hoja6.Range("A6")
        For cont = arranque To arranque + Hoja7.Range("A3")
            ufh1 = Hoja6.Range("C" & Rows.Count).End(xlUp).Row + 1
            .Range("A7", "K" & ufh).Copy Destination:=Hoja6.Range("A" & ufh1)
            For cont1 = 1 To 3
                Hoja6.Cells(Hoja6.Range("I" & Rows.Count).End(xlUp).Row - cont1 + 1, 9) = cont
            Next cont1
        Next cont
    End With
Hoja6.Select
End Sub
 

Conseguido, muchisimas gracias por la ayuda, sois unos maquinas.

Sub copiar(): Application.ScreenUpdating = False

    Hoja6.Range("A7", "A" & Hoja6.Range("C" & Rows.Count).End(xlUp).Row).EntireRow.Delete
    
    With Hoja7
        ufh = .Range("C" & Rows.Count).End(xlUp).Row
        arranque = .Range("I7")
        .Rows(6).Copy Hoja6.Range("A6")
        For cont = arranque To arranque + Hoja7.Range("A3")
            ufh1 = Hoja6.Range("C" & Rows.Count).End(xlUp).Row + 1
            .Range("A7", "K" & ufh).Copy
            Hoja6.Range("A" & ufh1).PasteSpecial xlPasteValues
            For cont1 = 1 To 3
                Hoja6.Cells(Hoja6.Range("I" & Rows.Count).End(xlUp).Row - cont1 + 1, 9) = cont
            Next cont1
        Next cont
    End With
Hoja6.Select
End Sub
 

Perfecto, me alegro

Perdonad que os moleste de nuevo, algo no termino de ver, hoy he adaptado el código y me funcionaba con la muestra que pusimos ayer, pero hoy con una tabla real, en concreto de 123 filas, resulta que el numero de copia solo me lo pone en 3 de ellas al final de cada duplicación pero en lo demás no, digamos que en si hago 2 copias, en las 123 filas de la primera copia, pone el valor inicial, pero a partir de ahí, solo le pone de las 123 filas de la segunda copia  a las 3 ultimas un 2 y no veo el porque, me podéis echar una mano, por favor. Este es mi código, que funciona con 3 filas pero si pongo mas el Valor de la columna I solo se rellena en las ultimas 3 filas de cada copia cuando son mas de 3.

Sub copiar(): Application.ScreenUpdating = False

    Hoja6.Range("A7", "A" & Hoja6.Range("C" & Rows.Count).End(xlUp).Row).EntireRow.Delete
    
    With Hoja7
        ufh = .Range("C" & Rows.Count).End(xlUp).Row
        arranque = .Range("I7")
        .Rows(6).Copy Hoja6.Range("A6")
        For cont = arranque To arranque + Hoja7.Range("A3")
            ufh1 = Hoja6.Range("C" & Rows.Count).End(xlUp).Row + 1
            .Range("A7", "K" & ufh).Copy
            Hoja6.Range("A" & ufh1).PasteSpecial xlPasteValues
            For cont1 = 1 To 3
                Hoja6.Cells(Hoja6.Range("I" & Rows.Count).End(xlUp).Row - cont1 + 1, 9) = cont
            Next cont1
        Next cont
    End With
Hoja6.Select
End Sub
 

Es curioso, solo pone el numero de copia correcto si son 3 filas, con 2 tampoco y mi intención es que el numero de filas es variable, no se si será posible.

Prueba, este es para el último archivo que compartí, no el último código

Sub copiar(): Application.ScreenUpdating = False

    Hoja3.Range("A1", "A" & Hoja3.Range("B" & Rows.Count).End(xlUp).Row).EntireRow.Delete
    With Hoja1
        ufh = .Range("B" & Rows.Count).End(xlUp).Row
        .Rows(6).Copy Hoja3.Range("A6")
        For cont = 1 To UserForm1.TextBox1.Value
            ufh1 = Hoja3.Range("B" & Rows.Count).End(xlUp).Row + 1
            .Range("A7", "I" & ufh).Copy Destination:=Hoja3.Range("A" & ufh1)
            For cont1 = 1 To ufh - 6
                Hoja3.Cells(Hoja3.Range("I" & Rows.Count).End(xlUp).Row - cont1 + 1, 9) = cont
            Next cont1
        Next cont
    End With
     UserForm1.ListBox1.RowSource = "'" & Hoja3.Name & "'!A6:I" & Hoja3.Range("B" & Rows.Count).End(xlUp).Row

End Sub

 

Usando tu último código sería :

Sub copiar(): Application.ScreenUpdating = False

    Hoja6.Range("A7", "A" & Hoja6.Range("C" & Rows.Count).End(xlUp).Row).EntireRow.Delete
    
    With Hoja7
        ufh = .Range("C" & Rows.Count).End(xlUp).Row
        arranque = .Range("I7")
        .Rows(6).Copy Hoja6.Range("A6")
        For cont = arranque To arranque + Hoja7.Range("A3")
            ufh1 = Hoja6.Range("C" & Rows.Count).End(xlUp).Row + 1
            .Range("A7", "K" & ufh).Copy
            Hoja6.Range("A" & ufh1).PasteSpecial xlPasteValues
            For cont1 = 1 To ufh-6
                Hoja6.Cells(Hoja6.Range("I" & Rows.Count).End(xlUp).Row - cont1 + 1, 9) = cont
            Next cont1
        Next cont
    End With
Hoja6.Select
End Sub

 

No puedo nada mas que quitarme el sombrero, muchísimas gracias.

No te lo vas a creer, pero por algun motivo me pega cosas en la hoja1

Me encantaria mostrarte el fichero real pero con el limite de 100kb es imposible

hace 13 horas, jcc-tec dijo:

Me encantaria mostrarte el fichero real pero con el limite de 100kb es imposible

Elimina todos los datos, imágenes y cualquier tipo de objeto, deja el archivo solo con las hojas, comprímelo (.zip) e intenta subirlo otra vez.

 

No se porque ocupa tanto pero no me da, se me queda en 400kb y solo tiene las formulas y lo que son las macros, de todas maneras se lo he pasado a JSDJSD, quizás el encuentre el problema, muy agradecido de todas maneras.

hace 20 horas, jcc-tec dijo:

No te lo vas a creer, pero por algun motivo me pega cosas en la hoja1

El motivo es que en la hoja CSV (Hoja1) donde te aparecen datos tienes formulas que hacen referencia a la hoja Proceso donde realizas las repeticiones de los datos. Si dichas formulas no tienen ninguna utilidad simplemente bórralas y tientes el tema resuelto.