Macro per copiare una riga nella prima riga libera della tabella sottostante

Question

Macro per copiare una riga nella prima riga libera della tabella sottostante

Anonimo

Ciao,

ho bisogno del Vostro aiuto!

Nel foglio "copia dati" importo dei dati da web.

Con una macro sono riuscito a scorporare tali dati nei vari fogli sottostanti.

Ora:

per ogni singolo foglio vorrei creare una macro (o una per tutti i fogli sarebbe meglio) che mi copi la riga C5:V5 nella prima riga libera della tabella sottostante (quindi c8:v8; c9:v9; ecc..).

Chi ha il buon cuore di aiutarmi please??? :)

Grazie

Alex

Domanda bloccata. Questa domanda è stata eseguita dalla community del supporto tecnico Microsoft. È possibile votare se è utile, ma non è possibile aggiungere commenti o risposte o seguire la domanda.

0 commenti

Risposta accettata dall'autore della domanda

8 risposte aggiuntive

Answer 1

Ciao Alex,

https://drive.google.com/file/d/1v9qMmfNgGnjN4BNUIdvZWu1BBGRy8D7k/view?usp=sharing

Eccolo, grazie!

Sostituisci il tuo codice con la seguente versione:

'=========>>

Option Explicit

'--------->>

Public Sub Copia_dati()

Dim WB As Workbook

Dim srcSH As Worksheet

Dim destSH1 As Worksheet, destSH2 As Worksheet

Dim destSH3 As Worksheet, destSH4 As Worksheet

Dim LRow As Long

Const sFoglio_Sorgente As String = "Copia dati"

Const sFoglio1 As String = "Segni puri Aggio BVS"

Const sFoglio2 As String = "Gol"

Const sFoglio3 As String = "Fattore 3D varie"

Const sFoglio4 As String = "Quote"

On Error GoTo XIT

Application.ScreenUpdating = False

Set WB = ThisWorkbook

With WB

Set srcSH = .Sheets(sFoglio_Sorgente)

Set destSH1 = .Sheets(sFoglio1)

Set destSH2 = .Sheets(sFoglio2)

Set destSH3 = .Sheets(sFoglio3)

Set destSH4 = .Sheets(sFoglio4)

End With

With destSH1

LRow = LastRow(SH:=destSH1, rng:=.Columns("B:B"), minRow:=4)

srcSH.Range("B2").Copy Destination:=.Range("B" & LRow + 1)

srcSH.Range("B6:D6").Copy Destination:=.Range("E" & LRow + 1)

srcSH.Range("B8:D8").Copy Destination:=.Range("H" & LRow + 1)

srcSH.Range("B11:D11").Copy Destination:=.Range("K" & LRow + 1)

srcSH.Range("B14:D14").Copy Destination:=.Range("N" & LRow + 1)

srcSH.Range("B16").Copy Destination:=.Range("Q" & LRow + 1)

srcSH.Range("B58:E58").Copy Destination:=.Range("R" & LRow + 1)

End With

With destSH2

LRow = LastRow(SH:=destSH2, rng:=.Columns("B:B"), minRow:=4)

srcSH.Range("B2").Copy Destination:=.Range("B" & LRow + 1)

srcSH.Range("B21:C21").Copy Destination:=.Range("C" & LRow + 1)

srcSH.Range("B23:C23").Copy Destination:=.Range("E" & LRow + 1)

srcSH.Range("B25:C25").Copy Destination:=.Range("G" & LRow + 1)

srcSH.Range("B27:C27").Copy Destination:=.Range("I" & LRow + 1)

srcSH.Range("B29:C29").Copy Destination:=.Range("K" & LRow + 1)

srcSH.Range("B31:C31").Copy Destination:=.Range("M" & LRow + 1)

srcSH.Range("B33:C33").Copy Destination:=.Range("O" & LRow + 1)

srcSH.Range("B35:C35").Copy Destination:=.Range("Q" & LRow + 1)

srcSH.Range("B37:C37").Copy Destination:=.Range("S" & LRow + 1)

srcSH.Range("B39:C39").Copy Destination:=.Range("U" & LRow + 1)

srcSH.Range("B41:C41").Copy Destination:=.Range("W" & LRow + 1)

srcSH.Range("B43:C43").Copy Destination:=.Range("Y" & LRow + 1)

End With

With destSH3

LRow = LastRow(SH:=destSH3, rng:=.Columns("B:B"), minRow:=4)

srcSH.Range("B2").Copy Destination:=.Range("B" & LRow + 1)

srcSH.Range("B48:E48").Copy Destination:=.Range("C" & LRow + 1)

srcSH.Range("B53:E53").Copy Destination:=.Range("G" & LRow + 1)

End With

With destSH4

LRow = LastRow(SH:=destSH4, rng:=.Columns("B:B"), minRow:=4)

srcSH.Range("B2").Copy Destination:=.Range("B" & LRow + 1)

srcSH.Range("B76:C76").Copy Destination:=.Range("C" & LRow + 1)

srcSH.Range("B78:C78").Copy Destination:=.Range("E" & LRow + 1)

srcSH.Range("B80:C80").Copy Destination:=.Range("G" & LRow + 1)

srcSH.Range("B82").Copy Destination:=.Range("I" & LRow + 1)

srcSH.Range("B84").Copy Destination:=.Range("J" & LRow + 1)

srcSH.Range("B86").Copy Destination:=.Range("K" & LRow + 1)

srcSH.Range("B88:C88").Copy Destination:=.Range("L" & LRow + 1)

srcSH.Range("B90:C90").Copy Destination:=.Range("N" & LRow + 1)

End With

Call MsgBox( _

Prompt:="Finito", _

Buttons:=vbInformation, _

Title:="REPORT")

XIT:

Application.ScreenUpdating = False

End Sub

'--------->>

Public Function LastRow(SH As Worksheet, _

Optional rng As Range, _

Optional minRow As Long = 1, _

Optional sPassword As String)

Dim bProtected As Boolean

With SH

If rng Is Nothing Then

Set rng = .Cells

End If

bProtected = .ProtectContents = True

If bProtected Then

Application.ScreenUpdating = False

.Unprotect Password:=sPassword

End If

End With

On Error Resume Next

LastRow = rng.Find(What:="*", _

after:=rng.Cells(1), _

Lookat:=xlPart, _

LookIn:=xlFormulas, _

SearchOrder:=xlByRows, _

SearchDirection:=xlPrevious, _

MatchCase:=False).Row

On Error GoTo 0

If LastRow < minRow Then

LastRow = minRow

End If

If bProtected Then

SH.Protect Password:=sPassword, _

UserInterfaceOnly:=True

End If

Application.ScreenUpdating = True

End Function

'<<=========

Potresti scaricare il mio file di prova Alex20180728.xlsm

===

Regards,

Norman

Answer 2

Anonimo

Posso allegare solo immagini, come si allega un file? te lo giro senza problemi...

grazie

0 commenti

Answer 3

Ciao Alex,

la macro è questa e, a seguire, immagine di un foglio del mio excel ma la cosa che cerco di fare è uguale per tutti e 4 i fogli:

Sub Salva_dati()

'

' Salva_dati Macro

'

Range("B5:U5").Select

Selection.Copy

Range("B7").Select

ActiveSheet.Paste

Sheets("Gol").Select

Range("B5:Z5").Select

Application.CutCopyMode = False

Selection.Copy

Range("B7").Select

ActiveSheet.Paste

Sheets("Fattore 3D varie").Select

Range("B5:J5").Select

Application.CutCopyMode = False

Selection.Copy

Range("B7").Select

ActiveSheet.Paste

Sheets("Quote").Select

Range("B5:O5").Select

Application.CutCopyMode = False

Selection.Copy

Range("B7").Select

ActiveSheet.Paste

Range("B7").Select

Sheets("Fattore 3D varie").Select

Range("B7").Select

Sheets("Gol").Select

Range("B7").Select

Sheets("Segni puri Aggio BVS").Select

Range("B7").Select

Sheets("Copia dati").Select

End Sub

in pratica sul Foglio "copia dati" mi importo i dati dal web.

Con una macro "copia" spezzetto i dati del primo foglio sui 4 successivi e sono perfetti nella riga 5.

Ora con questa macro che ho postato copio i dati nella riga 7. FINO A QUI TUTTO OK!

Ora il passaggio che mi manca: io voglio che la macro che ho creato NON copi sempre sulla riga 7 altrimenti mi va a sovrascrivere la riga precedente! Deve copiarli nella prima riga libera successiva (in questo caso la 8, poi la 9, ecc...)

Riesci ad aiutarmi così?

Prova a sostituire il tuo codice con qualcosa del genere:

'=========>>

Option Explicit

'--------->>

Public Sub Salva_dati()

Dim WB As Workbook

Dim SH As Worksheet

Dim srcRng As Range, destRng As Range

Dim LRow As Long

Set WB = ThisWorkbook

Application.ScreenUpdating = False

Call Copia(WB, "Copia dati", "B5:U5")

Call Copia(WB, "Gol", "B5:Z5")

Call Copia(WB, "Fattore 3D varie", "B5:J5")

Call Copia(WB, "Quote", "B5:O5")

XIT:

With Application

.ScreenUpdating = True

.CutCopyMode = False

End With

End Sub

'--------->>

Public Sub Copia(aWB As Workbook, _

sFoglio As String, _

sSorgente As String)

Dim SH As Worksheet

Dim rSrc As Range, rDest As Range

Set SH = aWB.Sheets(sFoglio)

With SH

Set rSrc = .Range(sSorgente)

LRow = LastRow(SH, .Columns("B:B"))

Set rDest = .Range("B" & LRow + 1)

End With

rSrc.Copy Destination:=rDest

End Sub

'--------->>

Public Function LastRow(SH As Worksheet, _

Optional rng As Range, _

Optional minRow As Long = 1, _

Optional sPassword As String)

Dim bProtected As Boolean

With SH

If rng Is Nothing Then

Set rng = .Cells

End If

bProtected = .ProtectContents = True

If bProtected Then

Application.ScreenUpdating = False

.Unprotect Password:=sPassword

End If

End With

On Error Resume Next

LastRow = rng.Find(What:="*", _

after:=rng.Cells(1), _

Lookat:=xlPart, _

LookIn:=xlFormulas, _

SearchOrder:=xlByRows, _

SearchDirection:=xlPrevious, _

MatchCase:=False).Row

On Error GoTo 0

If LastRow < minRow Then

LastRow = minRow

End If

If bProtected Then

SH.Protect Password:=sPassword, _

UserInterfaceOnly:=True

End If

Application.ScreenUpdating = True

End Function

'<<=========

Postscriptum:

Nota che in assenza di un file di esempio, non ho provato questo codice che ho scritto al volo.

===

Regards,

Norman

Answer 4

Ciao Norman,

la macro è questa e, a seguire, immagine di un foglio del mio excel ma la cosa che cerco di fare è uguale per tutti e 4 i fogli:

Sub Salva_dati()

'

' Salva_dati Macro

'

Range("B5:U5").Select

Selection.Copy

Range("B7").Select

ActiveSheet.Paste

Sheets("Gol").Select

Range("B5:Z5").Select

Application.CutCopyMode = False

Selection.Copy

Range("B7").Select

ActiveSheet.Paste

Sheets("Fattore 3D varie").Select

Range("B5:J5").Select

Application.CutCopyMode = False

Selection.Copy

Range("B7").Select

ActiveSheet.Paste

Sheets("Quote").Select

Range("B5:O5").Select

Application.CutCopyMode = False

Selection.Copy

Range("B7").Select

ActiveSheet.Paste

Range("B7").Select

Sheets("Fattore 3D varie").Select

Range("B7").Select

Sheets("Gol").Select

Range("B7").Select

Sheets("Segni puri Aggio BVS").Select

Range("B7").Select

Sheets("Copia dati").Select

End Sub

in pratica sul Foglio "copia dati" mi importo i dati dal web.

Con una macro "copia" spezzetto i dati del primo foglio sui 4 successivi e sono perfetti nella riga 5.

Ora con questa macro che ho postato copio i dati nella riga 7. FINO A QUI TUTTO OK!

Ora il passaggio che mi manca: io voglio che la macro che ho creato NON copi sempre sulla riga 7 altrimenti mi va a sovrascrivere la riga precedente! Deve copiarli nella prima riga libera successiva (in questo caso la 8, poi la 9, ecc...)

Riesci ad aiutarmi così?

Grazie!!!

Answer 5

Ciao Alex,

ho bisogno del Vostro aiuto!

Nel foglio "copia dati" importo dei dati da web.

Con una macro sono riuscito a scorporare tali dati nei vari fogli sottostanti.

Ora:

per ogni singolo foglio vorrei creare una macro (o una per tutti i fogli sarebbe meglio) che mi copi la riga C5:V5 nella prima riga libera della tabella sottostante (quindi c8:v8; c9:v9; ecc..).

Chi ha il buon cuore di aiutarmi please??? :)

Sebbene credo di aver io un buon cuore, penso sia adatto pubblicare il codice della tua macro e un file esemplificativo per dimostrare sia i dati iniziali che i risultati voluti da te.

Dato un tale file, credo che potremmo facilmente risolvere il tu problema. Forse dovresti riguadare il caricamento del file come una forma di quid pro quo ! :-)

===

Regards,

Norman

Condividi tramite

Macro per copiare una riga nella prima riga libera della tabella sottostante

8 risposte aggiuntive