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

Considerando che comunque vengono importati anche data di nascita e luogo di nascita ,eventuali duplicati sarebbero ininfluenti per i  loro scopi (due Anna Rossi nate nello stesso giorno,stesso mese e stesso luogo .... che sfiga .... ).

Non so' se invece potrebbe essere un problema per il  codice VBA .....

Prova qualcosa del genere:

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

Option Explicit

Public vArrIn As Variant

Public vArrOut() As Variant

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

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 oDic As Object

    Dim sStr As String, sUnivco As String

    Dim i As Long, j As Long

    Dim LRow As Long, LCol As Long

    Dim UB As Long, UB2 As Long

    Const sPrimoFoglio As String = "Elenco Iscritti"            '<<=== Modifica

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

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

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

    Const sCriterio As String = "SI"

    Set WB = ThisWorkbook

    With WB

        Set srcSH = WB.Sheets(sPrimoFoglio)

        If Not SheetExists(sSecondoFoglio) Then

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

            destSH.Name = sSecondoFoglio

        Else

            Set destSH = .Sheets(sSecondoFoglio)

        End If

    End With

    With srcSH

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

        LCol = LastCol(srcSH, .Rows(1))

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

                     .Resize(LRow - 1, LCol)

    End With

    Set destRng = destSH.Range(sPrimaCellaReport)

    vArrIn = srcRng.Value

    ReDim vArrOut(1 To UBound(vArrIn), 1 To UBound(vArrIn, 2) - 1)

    Set oDic = CreateObject("Scripting.Dictionary")

    With oDic

        .CompareMode = 0

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

            If UCase(vArrIn(i, 1)) = UCase(sCriterio) Then

                '\ Nome&Cognome&D.Nascita

                sUnivco = vArrIn(i, 2) & vArrIn(i, 3) & vArrIn(i, 4)

                If Not .exists(sUnivco) Then

                    j = j + 1

                    .Add Key:=sUnivco, Item:=vbNullString

                    Call CaricaRinnovi(i, j)

                End If

            End If

        Next i

    End With

    UB2 = UBound(vArrOut, 2)

    QuickSort vArrOut, 1, 1, j, True

    With destRng

        .Parent.UsedRange.ClearContents

        .Offset(1).Resize(j, UB2).Value = vArrOut

        .Resize(1, UB2).Value = srcRng.Cells(0, 2).Resize(1, UB2).Value

        Call FormatReport(.CurrentRegion)

    End With

End Sub

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

Public Function CaricaRinnovi(iRow As Long, jRow As Long)

    Dim i As Long

    For i = 2 To UBound(vArrIn, 2)

        vArrOut(jRow, i - 1) = vArrIn(iRow, i)

    Next i

End Function

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

Public Sub QuickSort(SortArray, col, L, R, bAscending)

'\ TomOgilvy: http://goo.gl/ninpZW

'Originally Posted by Jim Rech 10/20/98 Excel.Programming

'Modified to sort on first column of a two dimensional array

'Modified to handle a second dimension greater than 1 (or zero)

'Modified to do Ascending or Descending

    Dim i, j, X, Y, mm

    i = L

    j = R

    X = SortArray((L + R) / 2, col)

    If bAscending Then

        While (i <= j)

            While (SortArray(i, col) < X And i < R)

                i = i + 1

            Wend

            While (X < SortArray(j, col) And j > L)

                j = j - 1

            Wend

            If (i <= j) Then

                For mm = LBound(SortArray, 2) To UBound(SortArray, 2)

                    Y = SortArray(i, mm)

                    SortArray(i, mm) = SortArray(j, mm)

                    SortArray(j, mm) = Y

                Next mm

                i = i + 1

                j = j - 1

            End If

        Wend

    Else

        While (i <= j)

            While (SortArray(i, col) > X And i < R)

                i = i + 1

            Wend

            While (X > SortArray(j, col) And j > L)

                j = j - 1

            Wend

            If (i <= j) Then

                For mm = LBound(SortArray, 2) To UBound(SortArray, 2)

                    Y = SortArray(i, mm)

                    SortArray(i, mm) = SortArray(j, mm)

                    SortArray(j, mm) = Y

                Next mm

                i = i + 1

                j = j - 1

            End If

        Wend

    End If

    If (L < j) Then Call QuickSort(SortArray, col, L, j, bAscending)

    If (i < R) Then Call QuickSort(SortArray, col, i, R, bAscending)

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

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

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 Sub FormatReport(Rng As Range)

    With Rng

        .Parent.Rows(1).RowHeight = 30

        With .Rows(1)

            .HorizontalAlignment = xlCenter

            .VerticalAlignment = xlCenter

            .Interior.Color = RGB(255, 255, 0)

            With .Font

                .Bold = True

                .Color = RGB(255, 0, 0)

                .Underline = True

            End With

        End With

        .Select

        .CurrentRegion.EntireColumn.AutoFit

        With .FormatConditions

            .Delete

            .Add Type:=xlExpression, Formula1:= _

                 "=AND(LEN($A1)>0,MOD(ROW(),2)=0)"

            With .Item(1)

                With .Interior

                    .PatternColorIndex = xlAutomatic

                    .Color = RGB(234, 241, 221)

                End With

            End With

        End With

    End With

End Sub

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

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

https://www.dropbox.com/s/yncyh4ebd32g1b6/Claudio20160707.xlsm?dl=0

===

Regards,

Norman


Answer 3

ciao Norman

Considerando che comunque vengono importati anche data di nascita e luogo di nascita ,eventuali duplicati sarebbero ininfluenti per i  loro scopi (due Anna Rossi nate nello stesso giorno,stesso mese e stesso luogo .... che sfiga .... ).

Non so' se invece potrebbe essere un problema per il  codice VBA .....

Ciao    Grazie                  Claudio P

Answer 4

Ciao Claudio,

ho caricato il file su DropBox

https://www.dropbox.com/s/amrwg2ecaemy2f6/Lista%20Nomi%20Iscritti.xlsm?dl=0

Nel Foglio "Iscritti" (contiene l'anagrafica dell'anno precedente ...) nella colonna  B  viene inserita la condizione  "SI"  oppure "NO"   se il soggetto Rinnova oppure non rinnova  l'iscrizione

Nel Foglio "Rinnovi"  ...vengono copiati tutti i dati  dei soggetti che hanno rinnovato l'iscrizione  (questa sara' poi l'anagrafica di partenza per i Rinnovi dell'anno successivo ....)

questa e' la versione con le formule ....

Ho scaricato il tuo file.

In contrasto con la richiesta originale, i nomi sono in due colonne anziché una singola colonna. Di conseguenza, se ci potrebbe essere duplicazioni, al fine di estrarre solo i record univoci, sarebbe necessario prendere in considerazione sia la colonna nome e la colonna cognome Pertanto, ho bisogno di chiedere se siano possibili duplicazioni. Inoltre, cosa dovrebbe accadere nel caso di nomi e cognomi duplicati: per esempio se ci fossero due Anna Rossi nella lista?

===

Regards,

Norman


Answer 5

buon giorno Norman

ho caricato il file su DropBox

https://www.dropbox.com/s/amrwg2ecaemy2f6/Lista%20Nomi%20Iscritti.xlsm?dl=0

Nel Foglio "Iscritti" (contiene l'anagrafica dell'anno precedente ...) nella colonna  B  viene inserita la condizione  "SI"  oppure "NO"   se il soggetto Rinnova oppure non rinnova  l'iscrizione

Nel Foglio "Rinnovi"  ...vengono copiati tutti i dati  dei soggetti che hanno rinnovato l'iscrizione  (questa sara' poi l'anagrafica di partenza per i Rinnovi dell'anno successivo ....)

questa e' la versione con le formule ....

ciao  e grazie   Claudio P