Crea fogli e copia righe

Question

Ciao a tutti,

Ho bisogno del vostro aiuto per avere un codice che faccia quanto vado a descrivere.

In un file, ho un foglio che contiene una tabella che include le colonne da A:L. La prima riga riporta l'intestazione, a seguire vengono riportati i dati di diversi nominativi. Quello che mi servirebbe, è di creare un foglio per ogni valore che trova nella colonna E dalla riga 2 fino all'ultima riga. Naturalmente, per i valori che si ripetono, dev'essere creato un unico foglio.

Dopo aver creato i fogli, tutte le righe che riportano lo stesso valore, devono essere incollate nel foglio che riporta lo stesso nome trovato nella colonna E oltre a riportare la riga dell'intestazione. Pubblico un file che rende meglio il pensiero espresso. Ho creato manualmente il foglio che prende il nome bianco, e ho incollato le righe con quel valore riportato nella colonna E. L'esempio lo trovate qui.

Answer 1

Ciao Geacs,

Mentre il mio codice dovrebbe funzionare per qualsiasi versione di Excel, se utilizzi Excel 365 Excel 2019 o Excel 2021 e la tua tabella di dati è una tabella di Excel, potresti utilizzare il seguente codice molto più conciso:

'========>>

Option Explicit

'-------->>

Public Sub Tester()

Dim WB As Workbook 

Dim srcSH As Worksheet, destSH As Worksheet 

Dim srcRng As Range, destRng As Range, headerRng As Range 

Dim rNominativi As Range 

Dim oTabella As ListObject 

Dim arrNominativi As Variant, arrOut As Variant 

Dim sNominativo As String 

Dim i As Long, iCol As Long 

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

Const sColonna As String = **"E"                                      '<<=== Modifica** 

Const sTabella As String = **"Tabella1"                            '<<=== Modifica** 

Set WB = ThisWorkbook 

Set srcSH = WB.Sheets(sFoglio\_Sorgente) 

With srcSH 

    Set oTabella = .ListObjects(sTabella) 

    Set srcRng = oTabella.Range 

    Set headerRng = oTabella.HeaderRowRange 

    Set rNominativi = Intersect(oTabella.DataBodyRange, .Columns(sColonna)) 

    iCol = .Columns(sColonna).Column 

End With 

    arrNominativi = Application.Unique(rNominativi) 

For i = 1 To UBound(arrNominativi) 

    sNominativo = arrNominativi(i, 1) 

    With WB 

        If Not SheetExists(sNominativo) Then 

            Set destSH = .Sheets.Add(After:=.Sheets(.Sheets.Count)) 

            destSH.Name = arrNominativi(i, 1) 

        Else 

            Set destSH = .Sheets(sNominativo) 

            destSH.UsedRange.ClearContents 

        End If 

    End With 

    With Application 

        arrOut = .Filter(srcRng, .IsNumber(.Search(arrNominativi(i, 1), srcRng.Columns(5)))) 

    End With 

    Set destRng = destSH.Range("A2").Resize(UBound(arrOut), UBound(arrOut, 2)) 

    destRng.Value = arrOut 

    With headerRng 

        .Copy Destination:=destRng.Rows(0) 

        .Copy 

        destRng.Rows(0).PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, \_ 

            SkipBlanks:=False, Transpose:=False 

    End With 

Next i 

End Sub

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

Public Function SheetExists(sSheetName As String, _

Optional ByVal WB As Workbook) As Boolean 

On Error Resume Next 

If WB Is Nothing Then 

    Set WB = ThisWorkbook 

End If 

SheetExists = CBool(Len(WB.Sheets(sSheetName).Name)) 

End Function

'<<========

Potresti scaricare il mio file di prova Geacs2_20230110.xlsm

===

Regards,

Norman

Answer 2

Ciao Geacs,

Ho bisogno del vostro aiuto per avere un codice che faccia quanto vado a descrivere.

In un file, ho un foglio che contiene una tabella che include le colonne da A:L. La prima riga riporta l'intestazione, a seguire vengono riportati i dati di diversi nominativi. Quello che mi servirebbe, è di creare un foglio per ogni valore che trova nella colonna E dalla riga 2 fino all'ultima riga. Naturalmente, per i valori che si ripetono, dev'essere creato un unico foglio.

Dopo aver creato i fogli, tutte le righe che riportano lo stesso valore, devono essere incollate nel foglio che riporta lo stesso nome trovato nella colonna E oltre a riportare la riga dell'intestazione. Pubblico un file che rende meglio il pensiero espresso. Ho creato manualmente il foglio che prende il nome bianco, e ho incollato le righe con quel valore riportato nella colonna E. L'esempio lo trovate qui.

Indipendentemente dalla versione di Excel, 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, headerRng As Range 

Dim rNominativi As Range 

Dim arrNominativi As Variant, arrIn As Variant, arrOut() As Variant 

Dim sNominativo As String 

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

Dim UB As Long, UB2 As Long 

Dim LRow As Long 

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

Const sColonne As String = **"A:L"                                  '<<=== Modifica** 

Const sColonna As String = **"E"                                      '<<=== Modifica** 

Set WB = ThisWorkbook 

Set srcSH = WB.Sheets(sFoglio\_Sorgente) 

With srcSH 

    LRow = LastRow(srcSH, .Columns(sColonne)) 

    Set srcRng = .Columns(sColonne).Resize(LRow - 1).Offset(1) 

    Set headerRng = srcRng.Rows(0) 

    Set rNominativi = Intersect(srcRng, .Columns(sColonna)) 

    iCol = .Columns(sColonna).Column 

End With 

arrIn = srcRng.Value 

UB = UBound(arrIn) 

UB2 = UBound(arrIn, 2) 

ReDim arrOut(1 To UB, 1 To UB2) 

arrNominativi = SortedUniqueList(rNominativi.Value) 

For i = 1 To UBound(arrNominativi) 

sNominativo = arrNominativi(i) 

    With WB 

        If Not SheetExists(sNominativo) Then 

            Set destSH = .Sheets.Add(After:=.Sheets(.Sheets.Count)) 

            destSH.Name = arrNominativi(i) 

        Else 

            Set destSH = .Sheets(sNominativo) 

            destSH.UsedRange.ClearContents 

        End If 

    End With 

    For j = 1 To UB 

        If arrIn(j, iCol) = arrNominativi(i) Then 

            iCtr = iCtr + 1 

            For k = 1 To UB2 

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

            Next k 

        End If 

    Next j 

    Set destRng = destSH.Range("A2").Resize(iCtr, UB2) 

    destRng.Value = arrOut 

    With headerRng 

        .Copy Destination:=destRng.Rows(0) 

        .Copy 

        destRng.Rows(0).PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, \_ 

            SkipBlanks:=False, Transpose:=False 

    End With 

    iCtr = 0 

Next i 

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 SortedUniqueList(V As Variant)

Dim oSortedUniqueList As Object 

Dim arrOut() As Variant 

Dim sStr As String 

Dim i As Long 

Set oSortedUniqueList = CreateObject("System.Collections.Sortedlist") 

With oSortedUniqueList 

    For i = LBound(V) To UBound(V) 

        sStr = V(i, 1) 

        If Not sStr = vbNullString Then 

            If Not .ContainsKey(sStr) Then 

                .Add Key:=sStr, Value:=i 

            End If 

        End If 

    Next i 

    ReDim arrOut(1 To .Count) 

    For i = 0 To .Count - 1 

        arrOut(i + 1) = .GetKey(i) 

    Next i 

End With 

SortedUniqueList = arrOut 

End Function

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

Public Function SheetExists(sSheetName As String, _

Optional ByVal WB As Workbook) As Boolean 

On Error Resume Next 

If WB Is Nothing Then 

    Set WB = ThisWorkbook 

End If 

SheetExists = CBool(Len(WB.Sheets(sSheetName).Name)) 

End Function

'<<========

Potresti scaricare il mio file di prova Geacs20230110.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

Answer 3

Ciao Norman,

Ti ringrazio innanzitutto per l'aiuto e la tua disponibilità che manifesti sempre. Ho provato il codice che considera qualsiasi tipo di office.

Ho scaricato anche il file che hai pubblicato e ho riscontrato che effettivamente crea un foglio per ogni valore della colonna E. Tuttavia le righe che copia non sono le stesse del Foglio1. Se analizzi attentamente quello che copia, riscontrerai che in ordine progressivo a partire dal foglio azzurro la riga si ripete per 3 volte con gli stessi valori. La stessa cosa cosa con gli altri fogli.

Answer 4

Ciao Norman,

la versione 2019

Answer 5

Ciao Geacs.

Che versione di Excel stai usando?

===

Regards,

Norman