Macro per copiare righe e separare Nomi

Question

Salve,

spero che possiate aiutarmi con una macro che mi permetta risolvere il seguente problem

In pratica Nel Foglio1 ci possono essere piu righe(anche centinaia) e in particolare ogni riga nella colonna N contiene nomi separati da punto e virgola(es:Nome1,Nome2;etc).

Allora data una fila del Fo glio1 se per esempio questa contiene 25 nomi,allora nel Foglio2 dovró creare 25 file con gli stessi dati del Foglio1 eccetto la colonnaN che dovrá contenere solo un nome alla volta estratto da quella fila.

Spero di essere stato preciso nella descrizione del problema,in ogni caso aggiungo una excel con un esempio:

https://www.dropbox.com/s/w0szbp1ul7nq95k/Book1.xlsx

Grazie

Answer 1

Ho messo un'esempio qui

https://www.dropbox.com/s/w0szbp1ul7nq95k/Book1.xlsx

Il foglio1 contiene i dati di origine mentre il foglio2 il risultato che mi aspetto.

Nel foglio 1 la colonna N contiene sempre uno o piú nomi separati da punto e virgola. Per ogni nome contenuto nella cella voglio copiare tutto il contenuto della corrispondente fila nel foglio 2.

Ciao PC,

Prova:

Alt-F11 per aprire l'editor di VBA

Alt-IMper 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

    Dim arr As Variant

    Dim LRow As Long, LCol As Long

    Dim rCell As Range

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

    Dim CalcMode As Long

    Set WB = ActiveWorkbook

    With Application

        CalcMode = .Calculation

        .Calculation = xlCalculationManual

        .ScreenUpdating = False

    End With

    With WB

        Set srcSH = .Sheets("Sheet1")

        Set destSH = .Sheets("Sheet2")

    End With

    With srcSH

        LRow = LastRow(srcSH, .UsedRange)

        LCol = LastCol(srcSH, .UsedRange)

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

    End With

    With srcRng

        Set destRng = destSH.Range("A1").Resize(.Rows.Count, .Columns.Count)

    End With

    srcRng.Copy Destination:=destRng

    For i = LRow To 2 Step -1

        Set rCell = destRng.Cells(i, "N")

        arr = Split(rCell.Value, ";")

        j = UBound(arr)

        If CBool(j) Then

            With srcRng.Rows(i)

                .Resize(j).Insert Shift:=xlDown

                .Copy Destination:=.Offset(-j).Resize(j)

            End With

            For k = 0 To j

                srcRng.Cells(i + k, "N").Value = arr(k)

            Next k

        End If

    Next i

    With Application

        .Calculation = CalcMode

        .ScreenUpdating = True

    End With

End Sub

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

Function LastRow(SH As Worksheet, _

                 Optional Rng As Range)

    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

End Function

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

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.

Alt-F8 per aprire la finestrina macro

Seleziona Tester | Esegui

===

Regards,

Norman

Answer 2

PC7619

Allora data una fila del Foglio1 se per esempio questa contiene 25 nomi,allora nel Foglio2 dovró creare 25 file

Andrea

Forse intendevi 25 fogli ?!?

PC7619

No, mi riferivo a 25 righe

Difficile capire, eh.

Ho messo un'esempio qui

https://www.dropbox.com/s/w0szbp1ul7nq95k/Book1.xlsx

Il foglio1 contiene i dati di origine mentre il foglio2 il risultato che mi aspetto.

Nel foglio 1 la colonna N contiene sempre uno o piú nomi separati da punto e virgola. Per ogni nome contenuto nella cella voglio copiare tutto il contenuto della corrispondente fila nel foglio 2.

Answer 3

PC7619

Allora data una fila del Foglio1 se per esempio questa contiene 25 nomi,allora nel Foglio2 dovró creare 25 file

Andrea

Forse intendevi 25 fogli ?!?

PC7619

No, mi riferivo a 25 righe

Difficile capire, eh.

Answer 4

...

Allora data una fila del Foglio1 se per esempio questa contiene 25 nomi,allora nel Foglio2 dovró creare 25 file con gli stessi dati del Foglio1 eccetto la colonnaN che dovrá contenere solo un nome alla volta estratto da quella fila.

Forse intendevi 25 fogli ?!?

No, mi riferivo a 25 righe

Answer 5

...

Allora data una fila del Foglio1 se per esempio questa contiene 25 nomi,allora nel Foglio2 dovró creare 25 file con gli stessi dati del Foglio1 eccetto la colonnaN che dovrá contenere solo un nome alla volta estratto da quella fila.

Forse intendevi 25 fogli ?!?