Copiare dati tra fogli ma in posizioni diverse

[BG66]

Buona sera a tutti
...sperando che la vendemmia di Anthony sia andata a buon fine..
Come d'abitudine mi sono impelagato in qualcosa di più grosso di me
In pratica vorrei copiare i dati presenti nel foglio "Data Entry" nel foglio "DB" ma con un pò di personalizzazioni:
1) La data presente solamente in A1 (Data Entry) và riportata dall'ultima riga compilata in colonna A (DB). Quante volte dipende dai campi compilati delle altre colonne
2) I nomi degli atleti (range A2:A14 di Data entry) vanno accodati nella colonna C di DB
3) Nel riportare i valori le posizioni STATICO e DINAMICO vanno separate.
4) Dopo il trasferimento richiedere se voglio cancellare il range dei dati presenti in Data Entry ( ma questo penso di essere in grado di scriverlo da solo )

Se la cosa fosse stata facile avrei fatto cosi:

Codice: Seleziona tutto

Public Sub copiaMale()
   
    'dichiaro le variabili
    Dim sh1 As Worksheet
    Dim sh2 As Worksheet
        Application.ScreenUpdating = False
    'metto un riferimento ai due fogli
    With ThisWorkbook
        Set sh1 = .Worksheets("Data Entry")
        Set sh2 = .Worksheets("DB")
        uCol = sh1.Cells(1, Columns.Count).End(xlToLeft).Column
        uRiga = sh2.Cells(Rows.Count, 1).End(xlUp).Row + 1
    End With
   
    With sh1
        'copio da un foglio all'altro
        .Range("A2:U14").Copy
        sh2.Cells(uRiga, 1).PasteSpecial Paste:=xlValues
    End With
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    'Set a Nothing delle variabili oggetto
    Set sh2 = Nothing
    Set sh1 = Nothing
   
End Sub

https://www.dropbox.com/scl/fi/d2u2lfxsk5bnkygkkl5xn/statistiche-tiro_Forum.xlsm?dl=0&rlkey=47uacmeq8w5hvcxpoo6ny7x1k

Grazie per l'aiuto.
Gene

[Anthony47]

Forse:

Codice: Seleziona tutto

Sub CCopia()
Dim ColArr, ColNum, I As Long, myNext As Long
Dim DE As Worksheet, DB As Worksheet, iNum As Long
'
ColArr = Array("B", "L")
ColNum = Array(10, 10)
'
Set DE = Sheets("Data Entry")
Set DB = Sheets("DB")
iNum = DE.Range(DE.Range("B2"), DE.Range("B2").End(xlDown)).Rows.Count
For I = 0 To 1
    myNext = DB.Cells(Rows.Count, "C").End(xlUp).Row + 1
    DB.Cells(myNext, "B").Resize(iNum, 1).Value = DE.Cells(2, ColArr(I)).Resize(iNum, 1).Value
    DB.Cells(myNext, "C").Resize(iNum, 1).Value = DE.Cells(2, "A").Resize(iNum, 1).Value
    DB.Cells(myNext, "D").Resize(iNum, ColNum(I) - 1).Value = DE.Cells(2, ColArr(I)).Offset(0, 1).Resize(iNum, ColNum(I) - 1).Value
Next I
DB.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Resize(2 * iNum, 1).Value = DE.Range("A1").Value
'
' Qui il codice per la pulizia foglio DataEntry
'
End Sub


Ciao, fai sapere...

[BG66]

Ciao Anthony,
ovviamente funziona.
Per ripulire le celle, ho creato uno script ad hoc e lo richiamo nella tua macro con Call Elimina:

Codice: Seleziona tutto

Sub Elimina()
Dim answer As Integer
Dim DE As Worksheet

Set DE = Sheets("Data Entry")

    Application.ScreenUpdating = False
    answer = MsgBox("ATTENZIONE: stai per cancellare i dati, PROSEGUIRE?", vbYesNo + vbQuestion, "CANCELLA DATI")
    If answer = vbYes Then
    DE.Range("C2:K21").ClearContents ' cancella il contentuto del range
    DE.Range("M2:U21").ClearContents ' cancella il contentuto del range
    Else
    'fai niente
    End If
Application.ScreenUpdating = True
End Sub

Ma se volessi integrare il tuo script:
a) non riportare le righe dove tutte le celle del range D:L sono vuote?
b) disegnare le linee su quello che importo?

Grazie
Gene

[Anthony47]

Per i bordi, registrati una macro mentre selezioni un'area qualsiasi e ci applichi la formattazione dei bordi.
Dal codice registrato elimina la riga Range("xx:yy").Select.
Supponiamo che la macro si chiami Macro1, sostituisci nel codice che ti ho gia' dato queste righe:
Next I
DB.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Resize(2 * iNum, 1).Value = DE.Range("A1").Value
'
' Qui il codice per la pulizia foglio DataEntry

con questo nuovo blocco, che serve anche a ripulire le righe vuote:

Codice: Seleziona tutto

Next I
DB.Select
DB.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Resize(2 * iNum, ColNum(1) + 2).Select
Call Macro1
DB.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Resize(2 * iNum, 1).Value = DE.Range("A1").Value
For I = DB.Cells(Rows.Count, "A").End(xlUp).Row To DB.Cells(Rows.Count, "A").End(xlUp).Row - 2 * iNum Step -1
Cells(I, 1).Select
    If Application.WorksheetFunction.CountA(DB.Cells(I, 1).Resize(1, ColNum(1) + 2)) < 4 Then
        DB.Cells(I, 1).EntireRow.Delete
    End If
Next I
'
' Qui il codice per la pulizia foglio DataEntry
'


Ciao