Macro copia righe tante volte in base ad un valore

[Belvel]

Ciao
avrei bisogno di capire come fare tramite macro la seguente cosa:

Da A1 a N1 ho dei dati formattati con formule. A me serve di copiare verso il basso tale intervallo A1:N1, mantenendo la formattazione e le formule, tante volte a seconda del valore che metto nella cella P2.

Ad esempio, se in P2 metto il numero 3, la macro deve copiare 3 volte l'intervallo A1:N1 a partire da A2.
Se invece metto ad es 9, la macro deve copiare 9 volte l'intervallo A1:N1 a partire da A2, e così via.

Allego un esempio dove appunto da A1 a N1 ho tali dati:

http://www.filedropper.com/esempiotest_1

Grazie in anticipo
Belvel

[cromagno]

Ciao,
questo potrebbe essere un metodo...

Nel modulo di classe del Foglio:

Codice: Seleziona tutto

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Ncopie As Long
    Dim MyRng As Range
    Dim uRiga As Long
   
    If Not Intersect(Target, Range("P1")) Is Nothing Then
        If IsNumeric(Range("P1").Value) Then
            uRiga = Range("A" & Rows.Count).End(xlUp).Row
            Ncopie = Int(Range("P1").Value)
           
            Application.EnableEvents = False
            Application.ScreenUpdating = False
           
            Set MyRng = Range("A1:N1")
            If (Ncopie + 1) < uRiga Then
                Range("A2:N" & Rows.Count).Delete xlUp
                If Ncopie = 0 Then GoTo fine
            End If
            MyRng.Copy Range("A2:N" & Ncopie + 1)
fine:
            Application.EnableEvents = True
            Application.ScreenUpdating = True
        End If
    End If
   
    Set MyRng = Nothing
End Sub


Se in cella P1 metterai zero (0) ti rimarrà solo il range di origine.
File da scaricare:
https://www.dropbox.com/s/3qo8atwlybh8jt8/EsempioTest.xlsm?dl=0

Ciao
Tore

[FRIEDRICH]

Ciao a tutti,
un'alternativa all'esecuzione automatica proposta da Cromagno, il codice seguente da lanciare ogni volta sia necessario (da inserire in un modulo standard):

Codice: Seleziona tutto

Sub CopiaRighe()

    Dim NestRow As Long, i As Long, QuanteRighe As Long
   
    QuanteRighe = Range("P1").Value
   
   
        Application.ScreenUpdating = False
   
    With Foglio1
        .Range("A1:N1").Copy
        For i = 1 To QuanteRighe
       
            NestRow = .Cells(Rows.Count, "A").End(xlUp).Row
            Range("A" & NestRow + 1).PasteSpecial
        Next i
       
    End With
   
    Application.CutCopyMode = False
    Application.ScreenUpdating = True

End Sub

[Belvel]

grazie ad entrambi :-) Vanno benissimo.

Solo un'altra cosa: se il range da copiare cambiasse di volta in volta, come si dovrebbero adattare le macro?

Mi spiego meglio: si può generalizzare la macro per dirgli di copiare tante volte, a seconda del valore in P2, tutte le righe piene del range mantenendo la formattazione e le formule?

Il problema è che io a volte devo copiare, a seconda di quanto metto in P2, una solo riga (A1:N1), altre volte due righe(A1:N2) altre volte tre righe (A1:N3).

Ecco, vorrei che la macro intercettasse quante righe piene ci sono nel range da A ad N e che le ricopiasse tutte, mantenendo la formattazione e le formule, tante volte a seconda del valore in P2, partendo dalla prima riga vuota del range.

Se ad es. se il range da copiare fosse formato da 3 righe (da A1 a N3) e in P2 ci fosse ad es. 4, vorrei che la macro mi copiasse 4 volte il range A1:N3 a partire da A4.

In pratica la macro dovrebbe:

1) analizzare quante righe piene ci sono da A ad N, poi dovrebbe andare a vedere in P2 che valore c'è, e quindi dovrebbe copiare il range A:N tante volte in base al valore P2, a partire dalla prima riga vuota del range A:N.

Spero si possa fare
Grazie ancora
Belvel

[FRIEDRICH]

Ciao Belvel e grazie per il riscontro,

bisogna inserire una variabile (LastRow) che restituisca il numero dell'ultima riga utilizzata e quindi sostituire all'intervallo fisso Range("A1:N1") da copiare l'intervallo Range("A1:N" & LastRow). Di seguito il codice aggiornato:

Codice: Seleziona tutto

Sub CopiaRighe2()

    Dim NestRow As Long, i As Long, QuanteRighe As Long, LastRow As Long
   
    QuanteRighe = Range("P1").Value
    LastRow = Range("A" & Rows.Count).End(xlUp).Row
       
        Application.ScreenUpdating = False
   
    With Foglio1
        .Range("A1:N" & LastRow).Copy
       
        For i = 1 To QuanteRighe
       
            NestRow = .Cells(Rows.Count, "A").End(xlUp).Row
            Range("A" & NestRow + 1).PasteSpecial
        Next i
       
    End With
   
    Application.CutCopyMode = False
    Application.ScreenUpdating = True

End Sub

[Belvel]

Grazie infinite FRIEDRICH, va alla grande!!!!!!

Sono curioso di vedere anche la modifica della macro di Cromagno.
Grazie ancora
Belvel

[Belvel]

ritorno sull'argomento perché vorrei, prendendo spunto dal suggerimento di FRIEDRICH, vorrei modificare la macro di Cromagno in modo tale da copiare un range dinamico da A a N tante volte in base al valore di P1.

FRIEDRICH mi suggeriva di inserire una variabile (LastRow) che restituisca il numero dell'ultima riga utilizzata e quindi sostituire all'intervallo fisso Range("A1:N1"). Tale variabale che FRIEDRICH ha battezzato LastRow deve essere tale per cui Range("A" & Rows.Count).End(xlUp).Row

Se guardo la macro di Cromagno io trovo: uRiga = Range("A" & Rows.Count).End(xlUp).Row

Allora ho pensato di collegare uRiga alla variabile Set MyRng = Range("A1:N1") di Cromagno in questo modo: Set MyRng = Range("A1:N" & uRiga) ma purtroppo non succede nulla nel senso che continua a funzionare aggiungendo sempre e solo Una riga tante volte a seconda del valore in P1.

Ho provato anche ad aggiungere uRiga all'istruzione MyRng.Copy Range("A2:N" & Ncopie + 1) modificandola in MyRng.Copy Range("A2:N" & uRiga & Ncopie + 1)
Ma ho ottenuto solamente il moltiplicare in modo esponenziale il numero di righe da inserire.

Purtroppo i mie limiti sono tanti e non riesco proprio a capire dove sbaglio. Qui di seguto riporto la macro che ho modificato infruttuosamente.
Se qualcuno mi volesse dare un indizio per capire dove ho sbagliato gliene sarei grato :-)
Grazie
Belvel

Codice: Seleziona tutto

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Ncopie As Long
    Dim MyRng As Range
    Dim uRiga As Long
   
    If Not Intersect(Target, Range("P1")) Is Nothing Then
        If IsNumeric(Range("P1").Value) Then
            uRiga = Range("A" & Rows.Count).End(xlUp).Row
            Ncopie = Int(Range("P1").Value)
           
            Application.EnableEvents = False
            Application.ScreenUpdating = False
           
            Set MyRng = Range("A1:N" & uRiga) ''''' qui ho modoficato
            If (Ncopie + 1) < uRiga Then
                Range("A2:N" & Rows.Count).Delete xlUp
                If Ncopie = 0 Then GoTo fine
            End If
            MyRng.Copy Range("A2:N" & uRiga & Ncopie + 1) ''''' qui la seconda modifica
fine:
            Application.EnableEvents = True
            Application.ScreenUpdating = True
        End If
    End If
   
    Set MyRng = Nothing
End Sub


[Belvel]

Ciao Cromagno,

ho provato varie combinazioni, ma non riesco proprio nel mio intento di copiare un range dinamico da A a N tante volte in base al valore di P1.

Mi puoi aiutare per favore?

In pratica, nel mio foglio, io a volte ho una sola riga nel range A:N a volte due, a volte tre e così via.
Pertanto mi servirebbe copiare il range pieno A:N tante volte quante è il valore in P1.

Ho provato ad usare la variabile uRiga = Range("A" & Rows.Count).End(xlUp).Row collegandola a qualla Range ma non riesco ad avere quello che voglio.

Qui riporto la mia modifica. Vorrei capire dove ho sbagliato.
Grazie in anticipo.
Belvel

Codice: Seleziona tutto

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Ncopie As Long
    Dim MyRng As Range
    Dim uRiga As Long
   
    If Not Intersect(Target, Range("P1")) Is Nothing Then
        If IsNumeric(Range("P1").Value) Then
            uRiga = Range("A" & Rows.Count).End(xlUp).Row
            Ncopie = Int(Range("P1").Value)
           
            Application.EnableEvents = False
            Application.ScreenUpdating = False
           
            Set MyRng = Range("A1:N" & uRiga) ''''' qui ho modoficato
            If (Ncopie + 1) < uRiga Then
                Range("A2:N" & Rows.Count).Delete xlUp
                If Ncopie = 0 Then GoTo fine
            End If
            MyRng.Copy Range("A2:N" & uRiga & Ncopie + 1) ''''' qui la seconda modifica
fine:
            Application.EnableEvents = True
            Application.ScreenUpdating = True
        End If
    End If
   
    Set MyRng = Nothing
End Sub

[Anthony47]

Mi intrometto, perche' evidentemente Cromagno non ha ricevevuto altre notifiche dopo il messaggio di FRIEDRICH...

Leggendo e attuando alla lettera, dovrebbe funzionare questa variante della Worksheet_Change:

Codice: Seleziona tutto

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Ncopie As Long
    Dim MyRng As Range
    Dim uRiga As Long, I As Long
'
    If Target.Address = "$P$1" Then
        If IsNumeric(Range("P1").Value) Then
            uRiga = Evaluate("=max((A1:N1000<>"""")*(row(1:1000)))")
            Ncopie = Int(Range("P1").Value)
            Application.EnableEvents = False
            Set MyRng = Range("A1:N" & uRiga)
            For I = 1 To Ncopie
                uRiga = Evaluate("=max((A1:N1000<>"""")*(row(1:1000)))")
                MyRng.Copy Cells(uRiga + 1, 1)
            Next I
fine:
            Application.EnableEvents = True
        End If
    End If
    Set MyRng = Nothing
End Sub


Questa e' limitata a 1000 righe, se e' un limite modesto credo sia chiaro dove toccare.

Ciao

[Belvel]

Grazie come sempre Anthony. E' perfetta.
Saluti
Belvel