excel vba Copiare Range dati da una Colonna di un foglio e Trasporli in una riga di un altro foglio

Question

Buon Giorno

Nel Foglio1 ho creato una tabella dove ho replicato un Calendario Settimanale (quindi 52 Settimane) , le Date  (Es. lun 4 gen - dom 11 gen...) di ogni Settimana , sono poste su righe che hanno intervallo costante ogni 15 righe ( Riga 4 , Riga 19 , Riga 34 ..... ) .

Nel Foglio2  nella colonna  E  (E6:E369) sono riportate le date da Copiare e Incollare (Trasporre) nel foglio1 

Cambiando la data di inizio in E6 e' possibile Cambiare tutte le altre ( per Cambiare Anno )

Es:.  la prima settimana di gennaio  Copia Foglio2  E6:E12  ,  Incolla (Trasponi) Foglio1 C4:I4

         seconda settimana di gennaio  Copia Foglio2 E13:E19 , Incolla (Trasponi) Foglio1 C19:I9  etc.....    

Per automatizzare la procedura  Cambia Anno , utilizzo questo Codice

20

    With SH2

ThisWorkbook.Worksheets("Foglio2").Range("E6:E12").Copy

ThisWorkbook.Worksheets("Foglio1").Range("C4:I4").PasteSpecial xlPasteValues, Transpose:=True

    End With

25

    With SH2

ThisWorkbook.Worksheets("Foglio2").Range("E13:E19").Copy

ThisWorkbook.Worksheets("Foglio1").Range("C19:I19").PasteSpecial xlPasteValues, Transpose:=True

    End With

Con questo sistema dovrei (lo sto' facendo ) ripetere per 52 volte questa procedura , modificando di volta in volta i Range .

 Come  posso  Ovviare , ridurre le righe di codice  ??

                   Grazie per qualsiasi suggerimento        Claudio P

Answer 1

Nel Foglio1 ho creato una tabella dove ho replicato un Calendario Settimanale (quindi 52 Settimane) , le Date  (Es. lun 4 gen - dom 11 gen...) di ogni Settimana , sono poste su righe che hanno intervallo costante ogni 15 righe ( Riga 4 , Riga 19 , Riga 34 ..... ) .

Nel Foglio2  nella colonna  E  (E6:E369) sono riportate le date da Copiare e Incollare (Trasporre) nel foglio1 

Cambiando la data di inizio in E6 e' possibile Cambiare tutte le altre ( per Cambiare Anno )

Es:.  la prima settimana di gennaio  Copia Foglio2  E6:E12  ,  Incolla (Trasponi) Foglio1 C4:I4

         seconda settimana di gennaio  Copia Foglio2 E13:E19 , Incolla (Trasponi) Foglio1 C19:I9  etc.....    

Per automatizzare la procedura  Cambia Anno , utilizzo questo Codice

  

20

 

 

    With SH2

   

         ThisWorkbook.Worksheets("Foglio2").Range("E6:E12").Copy

   

        ThisWorkbook.Worksheets("Foglio1").Range("C4:I4").PasteSpecial xlPasteValues, Transpose:=True

   

   

    End With

   

25

   

    With SH2

   

         ThisWorkbook.Worksheets("Foglio2").Range("E13:E19").Copy

   

        ThisWorkbook.Worksheets("Foglio1").Range("C19:I19").PasteSpecial xlPasteValues, Transpose:=True

   

   

    End With

Con questo sistema dovrei (lo sto' facendo ) ripetere per 52 volte questa procedura , modificando di volta in volta i Range .

 Come  posso  Ovviare , ridurre le righe di codice  ??

Ciao Claudio,

Prova qualcosa del genere:

'========>>

Option Explicit

'-------->>

Public Sub Tester()

Dim WB As Workbook

Dim srcSH As Worksheet, destSH As Worksheet

Dim srcRng As Range, destRng As Range

Dim i As Long, iCtr As Long

Const sFoglio_Sorgente As String = "Foglio2" '<<=== Modifica

Const sFoglio\_Destinazione As String = **"Foglio1"        '<<=== Modifica**

Const sSorgente As String = **"E6:E369"                        '<<=== Modifica**

Const sDestinazione As String = **"C4"                          '<<=== Modifica**

Set WB = ThisWorkbook

With WB

    Set srcSH = .Sheets(sFoglio\_Sorgente)

    Set destSH = .Sheets(sFoglio\_Destinazione)

End With

Set srcRng = srcSH.Range(sSorgente)

Set destRng = destSH.Range(sDestinazione)

On Error GoTo XIT

Application.ScreenUpdating = False

For i = 1 To srcRng.Cells.Count Step 7

    iCtr = iCtr + 1

    srcRng.Cells(1).Offset(7 \* (iCtr - 1)).Resize(7).Copy

    destRng.Offset(15 \* (iCtr - 1)).PasteSpecial xlPasteValues, Transpose:=True

Next i

XIT:

Application.ScreenUpdating = True

End Sub

'<<========

===

Regards,

Norman

Answer 2

Buon giorno Norman

Grazie e' .... PERFETTISSIMO ..... FUNZIONA ALLA GRANDE

CIAO E GRAZIE ClaudioP

Ciao Claudio,

Mi fa piacere che tu abbia risolto il problema e ti ringrazio per il cortese riscontro.

Alla prossima.

===

Regards,

Norman

Answer 3

Buon giorno Norman

Grazie e' .... PERFETTISSIMO ..... FUNZIONA ALLA GRANDE

              CIAO  E  GRAZIE  ClaudioP