Condividi tramite

Copia/Incolla tra fogli - Da orizzontale a verticale, associandoli a voci specifiche

Anonimo
2023-01-26T13:41:25+00:00

Ciao a tutte/i. In un foglio excel ho alcune migliaia righe che dovrei ricopire su altro foglio, con una logica leggermente diversa.

In pratica:

  • sul foglio 1 ciascuna riga corrisponde alle configurazioni di 1 singolo utente
  • sul foglio 2 dovrei riportare in verticale queste voci, associandole all'utente di riferimento.

Probabilmente dovrei utilizzare una macro?

Ho caricato un esempio a questo link.

Grazie mille per l'aiuto.

Microsoft 365 e Office | Excel | Per la casa | Windows

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

Anonimo
2023-01-27T12:49:09+00:00

Ciao Francesco,

Ciao Norman, grazie per la tua risposta.

La struttura dei dati è quella che vedi nell'ultimo file. Naturalmente, le 4 righe erano solo un esempio :-) L'esigenza è quella indicata nel post originario (nel quale già parlavo di un file da migliaia di righe):

  • sul foglio 1 ciascuna riga riporta le configurazioni di 1 singolo utente
  • sul foglio 2 dovrei riportare in verticale le singole abilitazioni.

Faccio un esempio concreto:

  • nel foglio 1, l'utente "*** L'indirizzo e-mail viene rimosso per motivi di privacy *** Nome1 Cognome1" ha le abilitazioni 1,2,3,4,5,6,26 (tutte indicante nella riga 2)
  • nel foglio 2 dovrebbe essere riportato in verticale
    *** L'indirizzo e-mail viene rimosso per motivi di privacy *** Nome 1 Cognome 1 ABILITAZIONE 1
    *** L'indirizzo e-mail viene rimosso per motivi di privacy *** Nome 1 Cognome 1 ABILITAZIONE 2
    --- --- --- ---
    *** L'indirizzo e-mail viene rimosso per motivi di privacy *** Nome 1 Cognome 1 ABILITAZIONE 3
    --- --- --- ---
    *** L'indirizzo e-mail viene rimosso per motivi di privacy *** Nome 1 Cognome 1 ABILITAZIONE 4
    --- --- --- ---
    *** L'indirizzo e-mail viene rimosso per motivi di privacy *** Nome 1 Cognome 1 ABILITAZIONE 5
    --- --- --- ---
    *** L'indirizzo e-mail viene rimosso per motivi di privacy *** Nome 1 Cognome 1 ABILITAZIONE 6
    --- --- --- ---
    *** L'indirizzo e-mail viene rimosso per motivi di privacy *** Nome 1 Cognome 1 ABILITAZIONE 26
    --- --- --- ---

Spero che ora sia stato un pò più chiaro.

Grazie davvero per l'aiuto.

Prova la seguente leggera modifica del mio codice:

'========>>

Option Explicit

'-------->>

Public Sub Tester() 

Dim WB As Workbook 

Dim srcSH As Worksheet, destSH As Worksheet 

Dim srcRng As Range, destRng As Range, emailRng As Range 

Dim rCell As Range 

Dim arrIn As Variant, arrOut() As Variant 

Dim i As Long, j As Long, k As Long, iCtr As Long 

Dim LRow As Long, LCol As Long 

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

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

Const sDestinazione As String = **"A2"**                

Set WB = ThisWorkbook 

With WB 

    Set srcSH = .Sheets(sFoglio\_Sorgente) 

    Set destSH = .Sheets(sFoglio\_Destinazione) 

End With 

With srcSH 

    LRow = LastRow(srcSH, .Columns("A:A")) 

    LCol = LastCol(srcSH, .Rows(1)) 

    Set srcRng = .Range("A2").Resize(LRow, LCol) 

End With 

Set destRng = destSH.Range(sDestinazione) 

arrIn = srcRng.Value 

ReDim arrOut(1 To LRow \* LCol, 1 To 4) 

For i = 1 To UBound(arrIn) 

    For j = 4 To UBound(arrIn, 2) 

        If Not IsEmpty(arrIn(i, j)) Then 

            iCtr = iCtr + 1 

            For k = 1 To 3 

                arrOut(iCtr, k) = arrIn(i, k) 

            Next k 

            arrOut(iCtr, 4) = arrIn(i, j) 

        End If 

    Next j 

Next i 

On Error GoTo XIT 

Application.ScreenUpdating = False 

With destRng 

    .Resize(UBound(arrOut), UBound(arrOut, 2)).Value = arrOut 

    srcRng.Cells(1).Offset(-1).Resize(, 4).Copy Destination:=.Offset(-1) 

    .Offset(-1, 3).Value = "TIPO ABILITAZIONE" 

End With 

On Error Resume Next 

Set emailRng = destSH.Range(destRng, destRng.End(xlDown)) 

For Each rCell In emailRng.Cells 

    With rCell 

        .Hyperlinks.Add Anchor:=rCell, Address:=.Text, TextToDisplay:=.Text 

    End With 

Next rCell 

On Error GoTo XIT

destRng.EntireColumn.Resize(, 4).AutoFit 

Call MsgBox(Prompt:="Finito", \_ 

    Buttons:=vbInformation, \_ 

    Title:="REPORT")

XIT: 

Application.ScreenUpdating = True

End Sub

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

Public Function LastRow(SH As Worksheet, _ 

Optional Rng As Range, \_ 

Optional minRow As Long = 1) 

If Rng Is Nothing Then 

    Set Rng = SH.Cells 

End If 

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

End Function

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

Public Function LastCol(SH As Worksheet, _ 

             Optional Rng As Range) 

If Rng Is Nothing Then 

    Set Rng = SH.Cells 

End If 

On Error Resume Next 

LastCol = Rng.Find(What:="\*", \_ 

                   after:=Rng.Cells(1), \_ 

                   Lookat:=xlPart, \_ 

                   LookIn:=xlFormulas, \_ 

                   SearchOrder:=xlByColumns, \_ 

                   SearchDirection:=xlPrevious, \_ 

                   MatchCase:=False).Column 

On Error GoTo 0

End Function

'<<========

Potresti scaricare il mio file di [prova Francesco20230127.xlsm

Eseguendo questo codice con i tuoi dati, ottengo un report di output di 19593 righe che inizia come segue:

  [![Immagine](https://learn-attachment.microsoft.com/api/attachments/50f8c55b-62d2-4c8d-8f50-7f7da7407f90?platform=QnA"https://learn-attachment.microsoft.com/api/attachments/132d94c7-657a-4d24-a1ac-7eaa36850e86?platform=QnA" rel="ugc nofollow">Immagine

La risposta è stata utile?

1 persona ha trovato utile questa risposta.
0 commenti

7 risposte aggiuntive

Ordina per: Più utili
Più utili Più recente Meno recente
  1. Anonimo
    2023-01-27T10:40:07+00:00

    Ciao Francesco,

    In effetti la macro funziona sul tuo file. Se riverso i dati che mi servono, invece, mi da errore sulla seguente riga:

    ReDim arrOut(1 To LRow * LCol, 1 To LRow - 1)

    Ho caricato il nuovo file con tutti i dati. E' accessibile cliccando qui.

    Ho scaricato il tuo file e non capisco la struttura dei tuoi dati!

    Nello scenario originale, i dati iniziali per ciascun utente erano elencati su un'unica riga. Nel tuo file caricato, tra le altre cose, ogni utente appare su più righe. 

      [![Immagine](https://learn-attachment.microsoft.com/api/attachments/258452be-c4ed-4065-9dcd-8ef32f53f688?platform=QnA"https://learn-attachment.microsoft.com/api/attachments/132d94c7-657a-4d24-a1ac-7eaa36850e86?platform=QnA" rel="ugc nofollow">Immagine

    La risposta è stata utile?

    0 commenti
  2. Anonimo
    2023-01-27T09:51:10+00:00

    Ciao. Grazie mille per il supporto! :-)

    In effetti la macro funziona sul tuo file. Se riverso i dati che mi servono, invece, mi da errore sulla seguente riga:

    ReDim arrOut(1 To LRow * LCol, 1 To LRow - 1)

    Ho caricato il nuovo file con tutti i dati. E' accessibile cliccando qui.

    Grazie davvero per il tuo aiuto.

    La risposta è stata utile?

    0 commenti
  3. Anonimo
    2023-01-26T15:27:31+00:00

    Ciao Francesco,

    Ho dimenticato di aggiungere il link per il mio file di prova:

                 [**Francesco20230126.xlsm**](https://1drv.ms/x/s!AmTW9HzZG8cqlAkFjtxE5lsfTK8r?e=SZiFMD "https://1drv.ms/x/s!AmTW9HzZG8cqlAkFjtxE5lsfTK8r?e=SZiFMD")

    Ora ho corretto la mia risposta precedente per aggiungere questo link.

    ===

    Regards,

    Norman

    Immagine

    La risposta è stata utile?

    0 commenti
  4. Anonimo
    2023-01-26T15:21:14+00:00

    Ciao Francesco,

    Ciao a tutte/i. In un foglio excel ho alcune migliaia righe che dovrei ricopire su altro foglio, con una logica leggermente diversa.

    In pratica:

    • sul foglio 1 ciascuna riga corrisponde alle configurazioni di 1 singolo utente
    • sul foglio 2 dovrei riportare in verticale queste voci, associandole all'utente di riferimento.

    Probabilmente dovrei utilizzare una macro?

    Ho caricato un esempio a questo link.

    Prova qualcosa del genere:

    • Alt+F11 per aprire l'editor di VBA
    • Alt+IM per inserire un nuovo modulo di codice
    • Nel nuovo modulo vuoto, incolla il seguente codice:

    '========>>

    Option Explicit

    '-------->>

    Public Sub Tester() 

    Dim WB As Workbook 

Dim srcSH As Worksheet, destSH As Worksheet 

Dim srcRng As Range, destRng As Range, emailRng As Range 

Dim rCell As Range 

Dim rRow As Range 

Dim arrIn As Variant, arrOut() As Variant 

Dim i As Long, j As Long, k As Long, iCtr As Long 

Dim LRow As Long, LCol As Long 

Const sFoglio\_Sorgente As String = **"Foglio1"                  '&lt;&lt;==== Modifica** 

Const sFoglio\_Destinazione As String = **"Foglio2"            '&lt;&lt;==== Modifica** 

Const sDestinazione As String = "A2"               

Set WB = ThisWorkbook 

With WB 

    Set srcSH = .Sheets(sFoglio\_Sorgente) 

    Set destSH = .Sheets(sFoglio\_Destinazione) 

End With 

With srcSH 

    LRow = LastRow(srcSH, .Columns("A:A")) 

    LCol = LastCol(srcSH, .Rows(1)) 

    Set srcRng = .Range("A2").Resize(LRow, LCol) 

End With 

Set destRng = destSH.Range(sDestinazione) 

arrIn = srcRng.Value 

ReDim arrOut(1 To LRow \* LCol, 1 To LRow - 1) 

For i = 1 To UBound(arrIn) 

    For j = 4 To UBound(arrIn, 2) 

        If Not IsEmpty(arrIn(i, j)) Then 

            iCtr = iCtr + 1 

            For k = 1 To 3 

                arrOut(iCtr, k) = arrIn(i, k) 

            Next k 

            arrOut(iCtr, 4) = arrIn(i, j) 

        End If 

    Next j 

Next i 

With destRng 

    .Resize(UBound(arrOut), UBound(arrOut, 2)).Value = arrOut 

    srcRng.Cells(1).Offset(-1).Resize(, 4).Copy Destination:=.Offset(-1) 

    .Offset(-1, 3).Value = "TIPO ABILITAZIONE" 

End With 

On Error Resume Next 

Set emailRng = destSH.Range(destRng, destRng.End(xlDown)) 

For Each rCell In emailRng.Cells 

    With rCell 

        .Hyperlinks.Add Anchor:=rCell, Address:=.Text, TextToDisplay:=.Text 

    End With 

Next rCell 

On Error GoTo 0 

destRng.EntireColumn.Resize(, 4).AutoFit 

    Call MsgBox(Prompt:="Finito", \_ 

    Buttons:=vbInformation, \_ 

    Title:="REPORT")

    End Sub

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

    Public Function LastRow(SH As Worksheet, _ 

    Optional Rng As Range, \_ 

Optional minRow As Long = 1) 

If Rng Is Nothing Then 

    Set Rng = SH.Cells 

End If 

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 &lt; minRow Then 

    LastRow = minRow 

End If

    End Function

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

    Public Function LastCol(SH As Worksheet, _ 

                 Optional Rng As Range) 

If Rng Is Nothing Then 

    Set Rng = SH.Cells 

End If 

On Error Resume Next 

LastCol = Rng.Find(What:="\*", \_ 

                   after:=Rng.Cells(1), \_ 

                   Lookat:=xlPart, \_ 

                   LookIn:=xlFormulas, \_ 

                   SearchOrder:=xlByColumns, \_ 

                   SearchDirection:=xlPrevious, \_ 

                   MatchCase:=False).Column 

On Error GoTo 0

    End Function

    '<<========

    • Alt+Q per chiudere l'editor di VBA e tornare a Excel.
    • Salva il file con l'estensione xlsm
    • Alt+F8 per aprire la finestra di gestione delle macro
    • Seleziona Tester
    • Esegui

    Potresti scaricare il mio file di prova Francesco20230126.xlsm

    A causa di un problema con l'attuale editor del forum, che inserisce righe vuote indesiderate nel codice copiato dal forum, suggerirei di copiare il mio codice direttamente dal mio file di prova.

    ===

    Regards,

    Norman

    Immagine

    La risposta è stata utile?

    0 commenti