Importare in un Foglio Elenco Nomi da un altro Foglio solo se hanno valore "SI"

Question

Buon Giorno a Tutti

non riesco a trovare la formula che mi permetta di prelevare i Nomi da un Elenco Nomi nel Foglio1  e trascriverli nel Foglio2 ....solo se la condizione e'  "SI"    mi spiego ...

Nel Foglio1     cella  A1  "SI"  oppure  "NO"    cella    B1   "Pippo"

                                  A2  "SI"    """"      "NO"     """      B2   "Topolino" 

                                  A3    """    """       """"       """       B3   "Minny"   ........ eccetera fino a  A1500  ,   B1500

L'elenco nel Foglio1  e' ordinato in ordine alfabetico  A-Z  e di conseguenza nel Foglio2 dovra' essere equivalente 

Pensavo di utilizzare =cerca.vert(              ... ma mi sono incasinato ...perche' non riesco a dare univocita'  ai nomi

........................ una dritta e' bene accetta   GRAZIE     Claudio P

Answer 1

Ciao Claudio,

In alternativa, potrei postare una routine VBA da assegnare ad un pulsante.

Prova qualcosa del genere:

• Alt+F11 per aprire l'editor di VBA
• Menù | Inserisci | Modulo (oppure 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, critRng As Range

    Dim vArrIn As Variant, vArrOut() As Variant

    Dim vArrKeys As Variant

    Dim oDic As Object

    Dim sStr As String

    Dim i As Long

    Dim LRow As Long

    Const sPrimoFoglio As String = "Foglio1"              '<<=== Modifica

    Const sSecondoFoglio As String = "Foglio2"          '<<=== Modifica

    Const iRigaIntestazioni As Long = 4 '<<=== Modifica

    Const sCellaCriterio As String = "D2"                     '<<=== Modifica

    Const sPrimaCellaReport As String = "A1"              '<<=== Modifica

    Const sIntestazione As String = _

                              "Nomi Univoci "                          '<<=== Modifica

    Set WB = ThisWorkbook

    With WB

        Set srcSH = WB.Sheets(sPrimoFoglio)

        Set destSH = WB.Sheets(sSecondoFoglio)

    End With

    With srcSH

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

        Set srcRng = .Range("A" & iRigaIntestazioni + 1 & ":B" & LRow)

        Set critRng = .Range(sCellaCriterio)

    End With

    Set destRng = destSH.Range(sPrimaCellaReport)

    vArrIn = srcRng.Value

    Set oDic = CreateObject("Scripting.Dictionary")

    With oDic

        .CompareMode = 0

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

            sStr = critRng.Value

            If UCase(vArrIn(i, 1)) = UCase(critRng.Value) Then

                If Not .exists(sStr) Then

                    .Add Key:=vArrIn(i, 2), Item:=vbNullString

                End If

            End If

        Next i

        vArrKeys = Application.Transpose(SortedList(.keys))

        destRng.Offset(1).Resize(.Count).Value = vArrKeys

        destRng.Cells(1).Value = sIntestazione

    End With

End Sub

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

Public Function SortedList(V As Variant)

    Dim oSortedList As Object

    Dim arrOut() As Variant

    Dim sStr As String

    Dim i As Long

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

    With oSortedList

        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

    SortedList = arrOut

End Function

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

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

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

• 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 Claudio20160703.xlsm a:

https://www.dropbox.com/s/mmxsc0smn4e4zk1/Claudio20160703.xlsm?dl=0

===

Regards,

Norman


Answer 2

ciao Norman

ho trovato una soluzione empirica , con semplici formule ....

Foglio1

Colonna   A   Numerare Progressivamente le celle solo se nella colonna  B  la condizione  e'  "SI"

Colonna   B   Condizione     "SI"   oppure  "NO"

Colonna   C   Se  Colonna   B = "SI"   allora  NOME altrimenti  "" (nulla)

Colonna   D   NOME

in  A2  inserito Formula  =se(Lunghezza(C2)>1;MAX(A$1:C1)+1;"") numera progressivamente le celle nella colonna A  solo se in C  ci sono Valori

in  C2  inserito Formula   =se(B2="SI";D2;"")   riporta nella cella C2  il NOME solo se la condizione in B2  e' "SI"

Foglio2

Numerate Progressivamente le celle Colonna A    da  A2  a  A1501   ( da 1  a 1500 )

Colonna  B  (NOME)   inserito Formula    =cerca.vert(A2;'Foglio1'!$A$2:$D$1501;4;FALSO)

...quindi  nel Foglio1   ho questa situazione

A2    1       B2  "SI"      C2  PIPPO              D2  PIPPO

A3             B3  "NO"   C3                          D3  MINNY

A4    2       B4  "SI"      C4  PLUTO             D4  PLUTO

A5    3       B5  "SI"      C5  PAPERINO       D5  PAPERINO

nel Foglio2  il cerca.vert   importa solo i dati  riferiti ai numeri della Colonna A

.......Funziona .....   certo che con il codice si eviterebbero tutti i riferimenti tra i due Fogli  e sarebbe piu' elegante

GRAZIE   GRAZIE    ciao   Claudio

Answer 3

ciao Norman

.....scaricato tuo file esempio

fatto girare .....

Errore Run Time  2146232576(80131700)

Errore di Automazione

                    Debug

evidenziata questa riga     Set oSortedList = CreateBject("System.Collections.Sorted List")

devo aggiungere qualche riferimento a delle librerie ....???

Ciao    Grazie

Answer 4

ciao Norman e grazie

adesso faccio le prove  

.... Grazie  come al solito   sei grande    Ciao   Claudio

..... peccato per  il BRexit ....in tutti e due i casi     (l'ITAexit ...e' meno grave ...brucia ma e' solo calcio .....)

Answer 5

Ciao Claudio.

Partendo dal secondo foglio, puoi utilizzare lo strumento Filtro avanzato per estrarre un elenco univoco dei nomi dalla tabella sul primo foglio che corrispondono al tuo criterio:

Passo 1)

Passo 2)

Passo 3)

In alternativa, potrei postare una routine VBA da assegnare ad un pulsante.

===

Regards,

Norman