Riportare in successione valori da elenco anche ripetuti.

[gianca53Partecipante gianca53]

Ciao a tutti, come al solito mi trovo nella solita empasse di principiante , ovvero in colonna A ho un elenco casuale che poi riprendo in una cella mediante una scelta a  convalida , fatta questa scelta per es. PROG2 in colonna B dovrei selezionare tutte le occorrenza che hanno in colonna A il Prog.2 ,e  le devo riportare in sequenza una sotto l'atra in colonna F a partire da F19.  Allego immagine cosi si capisce . Ora con la macro che riporto ottengo solo l'ultimo dei valori di mio interesse , NERO , tutti gli altri li ha sovrascritti, mentre nella finestra immediata risultano tutti correttamente . In pratica manca il riferimento per il cambio riga . Banale,  ma è tutto il pomeriggio che ci sbatto la capa . Se qualcuno mi illumina ...   Grazie 

 

 

 

`Option Explicit
Sub CreaElncoDaSelezione2()
    Dim rng As Range
    Dim cell As Range
    Dim cella_iniziale As Range
    Dim Lr As Long
   Dim C
   Dim firstAddress As String
   ' intervallo di origine della ricerca

    Set rng = Range("A2:A14")
    Set cella_iniziale = Range("F19")

    Range("F18") = "DEFINIZIONI"

    Lr = Cells(Rows.Count, 6).End(xlUp).Row + 1
    Range("F19:F" & Lr).Clear

    With Worksheets("Foglio2").Range("A2:A" & Lr)
        Dim X As String
        X = Cells(17, 5).Value   ' stringa da cercare in E17

        Set C = .Find(X, LookIn:=xlValues, LookAt:=xlWhole)

        If Not C Is Nothing Then
            firstAddress = C.Address
            Do
                C.Cells.Offset(0, 1).Copy
                cella_iniziale.PasteSpecial
                Debug.Print cella_iniziale

                Set C = .FindNext(C)

            Loop While Not C Is Nothing And C.Address <> firstAddress

        Else
            MsgBox "Nome non Trovato"
        End If
    End With
End Sub
`

[alexps81Moderatore alexps81 Karma: 58 pts]

Ciao, volendo restare nel tuo codice...opterei per aggiungere questa riga di codice prima del Loop While:

Set cella_iniziale = cella_iniziale.Offset(1)

In pratica ad ogni nuovo ciclo, sposti alla riga sotto la variabile cella_iniziale

In realtà potresti anche fare a meno della variabile di tipo Range cella_iniziale ed utilizzare al suo posto una di tipo Long (magari la chiami riga) e quando devi incollare il dato copiato, lo incollerai così:

If Not C Is Nothing Then
    riga = 19
    firstAddress = C.Address
    Do
        C.Cells.Offset(0, 1).Copy
        Cells(riga, "F").PasteSpecial
        riga = riga + 1
        Set C = .FindNext(C)
    Loop While Not C Is Nothing And C.Address <> firstAddress
.....
.....
.....

Addirittura si può fare a meno anche del ciclo Do/Loop While e sfruttare il Filtro sulla Tabella ed incollare i valori visibili:

Sub CreaElencoDaSelezione_3()
    'senza ciclo
    Dim progetto As String
    Dim ur As Long
    Dim lo As ListObject
    Dim rng As Range
    
    Application.ScreenUpdating = False
    Set lo = Foglio2.ListObjects(1)
    
    progetto = Range("E17").Value
    Range("F18").Value = "DEFINIZIONI"
    ur = Cells(Rows.Count, "F").End(xlUp).Row
    If ur > 18 Then Range("F19:F" & ur).ClearContents
    
    With lo
        .ShowAutoFilterDropDown = True
        .Range.AutoFilter Field:=1, Criteria1:=progetto
        Set rng = .ListColumns(2).DataBodyRange.SpecialCells(xlCellTypeVisible)
        rng.Copy
        Range("F19").PasteSpecial xlPasteValues
        .Range.AutoFilter Field:=1
        .ShowAutoFilterDropDown = False
    End With
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

[gianca53Partecipante gianca53]

@alexps81, 

Grazie ai tuoi suggerimenti ho risolto l'empasse in cui ero finito, ma soprattutto ho capito dove sbagliavo . 

Non sono invece riuscito a provare la versione (3) con filtro mi dà errore qui : 

Set lo = Foglio2.ListObjects(1)

errore 424 manca oggetto ?

[alexps81Moderatore alexps81 Karma: 58 pts]

gianca53 ha scritto:

Non sono invece riuscito a provare la versione (3) con filtro mi dà errore qui : 

Set lo = Foglio2.ListObjects(1)

errore 424 manca oggetto ?

Ma l'elenco che hai in "A1:B14" appartiene ad una ListObject? (A me così sembra).

Il codeName del foglio è Foglio2? Se effettivamente quella in "A1:B14" è una tabella ListObject, allora il problema può risiedere nel codeName del Foglio. Prova a modificare quello.

[gianca53Partecipante gianca53]

Si, hai ragione, 

era foglio1 denominato foglio2 nella linguetta, corretto , tutto OK.   

[Autore]

Articoli