SE UNA CELLA CORRISPONDE A UN VALORE COPIA INTERA RIGA IN UN ALTRO FOGLIO

Question

Vorrei sapere come risolvere il mio problema, vorrei far si che inserendo nel campo ID il valore L1 copi automaticamente l'intera riga nel foglio L1 e inserendo in ID il valore L2 che copi automaticamente l'intera riga nel foglio L2.

Answer 1

Ciao NiccoDessì,

• Fai clic dx sulla linguetta del foglio Elenco
• Seleziona l'opzione Visualizza Codice dal **** menu contestuale risultante
• Cancella il codice esistente
• Incolla il seguente codice:

'=========>>

Option Explicit

Private Sub Worksheet_Deactivate()

    Dim RngID As Range

    Dim Sh As Worksheet, newSH As Worksheet, destSH As Worksheet

    Dim destRng As Range, RngIntestazioni As Range

    Dim sStr As String

    Dim i As Long, LRow As Long, LCol As Long

    With Me

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

LCol = .Columns(sUltimaColonna).Column

        Set RngIntestazioni = .Range("A" & iRigaIntestazioni). _

                              Resize(1, LCol)

        Set RngID = .Range("A" & iRigaIntestazioni + 1). _

                    Resize(LRow - iRigaIntestazioni, 1)

    End With

    On Error GoTo XIT

    Application.EnableEvents = False

    For i = 2 To RngID.Cells.Count

        sStr = RngID.Cells(i).Value

        If Not SheetExists(sStr) Then

            Call AddSheet(sStr)

            Set destSH = ThisWorkbook.Sheets(sStr)

            RngIntestazioni.Copy Destination:=destSH.Range("A1")

        End If

    Next i

XIT:

    With Application

        .ScreenUpdating = True

        .EnableEvents = True

    End With

    End Sub

    '<<========= 

• Ctrl+R per accedere alla finestra Project Explorer ('Gestione progetti')
• Fai doppio clic sul Module1
• Cancella il codice esistente
• incolla il seguente codice:

'=========>>

Option Explicit

Public Const sFoglioElenco As String = "Elenco"

Public Const sUltimaColonna As String = "K"

Public Const iRigaIntestazioni As String = 6

Public Const sFogliDaEscludere As String = _

                                         "Pippo,Pluto,Paperino"               '<<=== Modifica

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

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

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

Public Function AddSheet(newSheetName As String, _

                         Optional ByVal Wb As Workbook)

    Dim Sh As Worksheet, newSH As Worksheet

    Dim bFlag As Boolean

    If Wb Is Nothing Then

        Set Wb = ThisWorkbook

    End If

    On Error GoTo XIT

    Application.ScreenUpdating = False

    With Wb

        For Each Sh In Wb.Worksheets

            If newSheetName < Sh.Name And Sh.Name <> sFoglioElenco Then

                Set newSH = .Sheets.Add(before:=Sh)

                bFlag = True

                Exit For

            End If

        Next Sh

        If Not bFlag Then

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

        End If

    End With

    newSH.Name = newSheetName

XIT:

    Application.ScreenUpdating = True

End Function

'<<========

• Fai doppio clic sul modulo ThisWorkbook (Questa_cartella_di_Lavoro) del file
• Incolla il seguente codice

'=========>>

Option Explicit

Option Compare Text

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

Private Sub Workbook_SheetActivate(ByVal Sh As Object)

    Dim Wb As Workbook

    Dim srcSH As Worksheet

    Dim srcRng As Range, destRng As Range

    Dim arrEscludere As Variant

    Dim arrIn As Variant, arrOut() As Variant

    Dim Res As Variant

    Dim sStr As String

    Dim iRow As Long, jRow As Long, iCol As Long

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

arrEscludere = Split(sFogliDaEscludere, ",")

    Res = Application.Match(Sh.Name, arrEscludere, 0)

    If Not IsError(Res) Or Sh.Name = sFoglioElenco Then

        Exit Sub

    End If

    Set srcSH = Me.Sheets(sFoglioElenco)

    With srcSH

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

iCol = .Columns(sUltimaColonna).Column

        Set srcRng = .Range("A" & iRigaIntestazioni). _

                     Resize(iRow - iRigaIntestazioni + 1, iCol)

    End With

    arrIn = srcRng.Value

    sStr = Sh.Name

    Sh.UsedRange.Offset(1).ClearContents

    For i = 2 To UBound(arrIn)

        If arrIn(i, 1) = sStr Then

            iCtr = iCtr + 1

            ReDim Preserve arrOut(1 To iCol, 1 To iCtr)

            For j = 1 To iCol

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

            Next j

        End If

    Next i

    If CBool(iCtr) Then

        Set destRng = Sh.Range("A2").Resize(iCtr, iCol)

        destRng.Value = Application.Transpose(arrOut)

End If

End Sub

'<<=========

• Alt+Q per chiudere l'editor di VBA e tornare a Excel
• Salva il file con l’estensione xlsm.

Potresti scaricare il mio file di prova  Nico 20161028.xlsm a:

https://www.dropbox.com/s/6on93rbi4y31sld/Nico20161028.xlsm?dl=0

===

Regards,

Norman

Answer 2

Nelle pagine IL, L1... non mi copia tutti i nomi ma solo il primo, perché?

Answer 3

Ciao NiccoDessì.

Grazie, ma come faccio se voglio aggiuengere un altro ID e quindi una nuova pagina? Per esempio 1M

Ci ho già pensato - prova ad aggiungere più codice! Vedrai che i nuovi fogli saranno creati e riempiti automaticamente.

===

Regards,

Norman

Answer 4

Grazie, ma come faccio se voglio aggiuengere un altro ID e quindi una nuova pagina? Per esempio 1M

Answer 5

Ciao NiccoDessì,

Vorrei sapere come risolvere il mio problema, vorrei far si che inserendo nel campo ID il valore L1 copi automaticamente l'intera riga nel foglio L1 e inserendo in ID il valore L2 che copi automaticamente l'intera riga nel foglio L2.

• Fai clic dx sulla linguetta del foglio Elenco
• Seleziona l'opzione Visualizza Codice dal **** menu contestuale risultante
• Incolla il seguente codice:

'=========>>

Option Explicit

Private Sub Worksheet_Deactivate()

    Dim RngTabella As Range

    Dim SH As Worksheet, newSH As Worksheet, destSH As Worksheet

    Dim sStr As String

    Dim i As Long, LRow As Long, LCol As Long

    Const iPrimaRiga As Long = 6                           '<<=== Modifica

    Const sUltimaColonna As String = "I"                '<<=== Modifica

    With Me

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

        LCol = .Columns(sUltimaColonna).Column

        Set RngTabella = .Range("A" & iPrimaRiga). _

                         Resize(LRow - iPrimaRiga + 1, LCol)

    End With

    For i = 2 To RngTabella.Rows.Count

        sStr = RngTabella.Cells(i, 1).Value

        If Not SheetExists(sStr) Then

            Call AddSheet(sStr)

        End If

        Set destSH = ThisWorkbook.Sheets(sStr)

        On Error GoTo XIT

        Application.ScreenUpdating = False

        With RngTabella

            .Rows(1).Copy Destination:=destSH.Range("A1")

            .Rows(i).Copy Destination:=destSH.Range("A2")

        End With

    Next i

XIT:

    Application.ScreenUpdating = True

End Sub

'<<=========

• Alt+IM per inserire un nuovo modulo di codice
• Nel nuovo modulo vuoto, incolla il seguente codice:

'=========>>

Option Explicit

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

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

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

Public Function AddSheet(newSheetName As String, _

                         Optional ByVal WB As Workbook)

    Dim SH As Worksheet, newSH As Worksheet

    Dim bFlag As Boolean

    If WB Is Nothing Then

        Set WB = ThisWorkbook

    End If

    On Error GoTo XIT

    Application.ScreenUpdating = False

    With WB

        For Each SH In WB.Worksheets

            If newSheetName < SH.Name Then

                Set newSH = .Sheets.Add(before:=SH)

                bFlag = True

                Exit For

            End If

        Next SH

        If Not bFlag Then

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

        End If

    End With

    newSH.Name = newSheetName

XIT:

    Application.ScreenUpdating = True

End Function

'<<=========

• Alt+Q per chiudere l'editor di VBA e tornare a Excel
• Salva il file con l’estensione xlsm

Potresti scaricare il mio file di prova Nico20161027.xlsm a:

https://www.dropbox.com/s/0jx7r8k8zw6dzax/Nico20161027.xlsm?dl=0

===

Regards,

Norman